12:36 PM 9-JUN-99 CHR SYSTEM (BCH) VERSION 1.0 PATCH 7 BCH10P1 BCH10P1 ; IHS/TUCSON/LAB - patch 1 to bch for icd update ; ;;1.0;IHS RPMS CHR SYSTEM;**1**;OCT 28, 1996 ; ;update 1 code in ICD crosswalk for 97 updates I '$D(^BCHTPROB) W !,"CHR Package NOT installed.",! Q S DA=$O(^BCHTPROB("B","OBESITY","")) I 'DA W !,"Obesity Entry not found in CHR HEALTH PROBLEM CODE FILE. NOTIFY PROGRAMMER." Q S DIE="^BCHTPROB(",DR=".04///278.00" D ^DIE I $D(Y) W !,$C(7),$C(7),"Updating of Obesity Code failed!! Notify programmer.",! W !,"ICD update of CHR - ICD crosswalk complete.",! K DA,DIE,DR Q BCH10P6 BCH10P6 ;IHS/CMI/LAB - IHS CHR patch 6 [ 09/18/98 1:29 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**6**;OCT 28, 1996 ; ;go through all chr records, if any service is HE or CF ;find V POV and change code accordingly START ;start processing patch 6 S ZTQUEUED="" ;to prevent other routine from talking S (BCHRIEN,BCHCNT)=0 F S BCHRIEN=$O(^BCHR(BCHRIEN)) Q:BCHRIEN'=+BCHRIEN D .Q:'$P(^BCHR(BCHRIEN,0),U,15) ;no pcc visit created .S (BCHP,BCHGOT)=0 F S BCHP=$O(^BCHRPROB("AD",BCHRIEN,BCHP)) Q:BCHP'=+BCHP D ..Q:'$D(^BCHRPROB(BCHP)) ..Q:$P(^BCHRPROB(BCHP,0),U,4)="" ..S X=$P(^BCHRPROB(BCHP,0),U,4),X=$P(^BCHTSERV(X,0),U,3) ..Q:'(X="HE"!(X="CF")) ..S BCHGOT=1 ..Q .Q:'BCHGOT .W " ",BCHRIEN .S BCHCNT=BCHCNT+1 .S BCHR=BCHRIEN .S BCHEV("TYPE")="E" .S BCHEV("VFILES",9000010)=$P(^BCHR(BCHR,0),U,15) .S X=0 F S X=$O(^BCHR(BCHR,31,X)) Q:X'=+X S F=$P(^BCHR(BCHR,31,X,0),U),N=$P(^(0),U,2) I F,N S BCHEV("VFILES",F,N)="" .K ^BCHR(BCHR,31) .D PROTOCOL^BCHUADD1 .Q W !!,"All done updating. ",BCHCNT," CHR Records updated.",! D EN^XBVK("BCH") K ZTQUEUED Q BCH1I001 BCH1I001 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",11,0) ;;=BCH EDIT RECORD DATA^^^^2941013^^^90002^0^0^1 ;;^UTILITY(U,$J,"DIST(.403,",11,40,0) ;;=^.4031I^4^4 ;;^UTILITY(U,$J,"DIST(.403,",11,40,1,0) ;;=1^^1,1^^^0 ;;^UTILITY(U,$J,"DIST(.403,",11,40,1,1) ;;=CHR RECORD EDIT ;;^UTILITY(U,$J,"DIST(.403,",11,40,1,40,0) ;;=^.4032PI^31^1 ;;^UTILITY(U,$J,"DIST(.403,",11,40,1,40,31,0) ;;=BCH EDIT RECORD DATA^1^1,1^e ;;^UTILITY(U,$J,"DIST(.403,",11,40,1,40,"AC",1,31) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,1,40,"B",31,31) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,2,0) ;;=1.2^^1,2^^^1^17,77 ;;^UTILITY(U,$J,"DIST(.403,",11,40,2,1) ;;=Page 1.2 ;;^UTILITY(U,$J,"DIST(.403,",11,40,2,40,0) ;;=^.4032IP^113^1 ;;^UTILITY(U,$J,"DIST(.403,",11,40,2,40,113,0) ;;=BCH EDIT TESTS/MSR/RF^1^2,2^e ;;^UTILITY(U,$J,"DIST(.403,",11,40,2,40,"AC",1,113) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,2,40,"B",113,113) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,0) ;;=1.4^^1,1 ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,1) ;;=Page 1.4 ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,0) ;;=^.4032IP^124^2 ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,123,0) ;;=BCH POV HEADER BLOCK^1^1,1^e ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,124,0) ;;=BCH POV EDIT BLK^2^7,1^e ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,124,2) ;;=6^AD^n^0 ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,"AC",1,123) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,"AC",2,124) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,"B",123,123) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,3,40,"B",124,124) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,4,0) ;;=1.6^^6,1^^^1^10,75 ;;^UTILITY(U,$J,"DIST(.403,",11,40,4,1) ;;=Page 1.6 ;;^UTILITY(U,$J,"DIST(.403,",11,40,4,40,0) ;;=^.4032IP^125^1 ;;^UTILITY(U,$J,"DIST(.403,",11,40,4,40,125,0) ;;=BCH POV PROV NARR^1^1,1^e ;;^UTILITY(U,$J,"DIST(.403,",11,40,4,40,"AC",1,125) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,4,40,"B",125,125) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"B",1.2,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"B",1.4,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"B",1.6,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"C","CHR RECORD EDIT",1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"C","PAGE 1.2",2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"C","PAGE 1.4",3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,40,"C","PAGE 1.6",4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,0,0,"N") ;;=15,31^2,31^2,31^15,31^2,31 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31) ;;=0^0^90002^^e^^^^2 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,2,"D") ;;=2^18^20^.01 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,2,"N") ;;=0^12^3^0^3 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,3,"D") ;;=2^52^20^.02 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,3,"N") ;;=0^5^12^2^12 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,4,"D") ;;=7^37^20^.06 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,4,"N") ;;=16^6^6^16^6 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,5,"D") ;;=3^52^20^.03 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,5,"N") ;;=3^16^16^12^16 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,6,"D") ;;=8^37^20^.05 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,6,"N") ;;=4^7^7^4^7 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,7,"D") ;;=9^37^20^.07 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,7,"N") ;;=6^9^9^6^9 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,8,"D") ;;=11^37^40^.09 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,8,"N") ;;=9^10^10^9^10 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,9,"D") ;;=10^37^20^.08 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,9,"N") ;;=7^8^8^7^8 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,10,"D") ;;=12^37^6^.11 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,10,"N") ;;=8^13^11^8^11 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,11,"D") ;;=12^57^5^.12 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,11,"N") ;;=8^13^13^10^13 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,12,"D") ;;=3^18^20^1108 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,12,"N") ;;=2^16^5^3^5 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,13,"D") ;;=13^37^40^2101 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,13,"N") ;;=10^14^14^11^14 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,14,"D") ;;=14^37^40^2102 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,14,"N") ;;=13^18^17^13^17 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,15,"D") ;;=16^37^1^15,31 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,15,"N") ;;=18^0^0^19^0 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,16,"D") ;;=5^37^1^16,31 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,16,"N") ;;=12^4^4^5^4 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,17,"D") ;;=15^16^1^5101 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,17,"N") ;;=14^15^18^14^18^^^^^^1 BCH1I002 BCH1I002 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,18,"D") ;;=15^35^1^6101 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,18,"N") ;;=14^15^19^17^19^^^^^^1 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,19,"D") ;;=15^60^1^7101 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,31,19,"N") ;;=14^15^15^18^15^^^^^^1 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",1,"FIRST") ;;=2,31 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,0,0,"N") ;;=10,113^2,113^2,113^15,113^2,113 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113) ;;=1^2^90002^^e^^^^2 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,2,"D") ;;=5^10^10^1201 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,2,"N") ;;=0^3^16^0^16 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,3,"D") ;;=6^10^10^1202 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,3,"N") ;;=2^4^4^16^4 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,4,"D") ;;=7^10^10^1203 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,4,"N") ;;=3^5^18^3^18 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,5,"D") ;;=8^10^10^1204 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,5,"N") ;;=4^24^23^19^23 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,6,"D") ;;=10^10^10^1205 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,6,"N") ;;=24^7^25^27^25 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,7,"D") ;;=11^10^10^1206 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,7,"N") ;;=6^8^8^28^8 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,8,"D") ;;=13^10^10^1207 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,8,"N") ;;=7^9^9^7^9 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,9,"D") ;;=14^10^10^1208 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,9,"N") ;;=8^10^10^8^10 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,10,"D") ;;=15^10^10^1209 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,10,"N") ;;=9^0^14^9^14 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,14,"D") ;;=15^34^11^.13 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,14,"N") ;;=9^0^15^10^15 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,15,"D") ;;=15^59^5^.14 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,15,"N") ;;=9^0^0^14^0 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,16,"D") ;;=5^31^11^1210 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,16,"N") ;;=0^3^3^2^3 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,18,"D") ;;=7^45^11^1301 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,18,"N") ;;=3^23^19^4^19 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,19,"D") ;;=7^66^8^1302 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,19,"N") ;;=3^26^5^18^5 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,23,"D") ;;=8^45^11^1303 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,23,"N") ;;=18^24^26^5^26 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,24,"D") ;;=9^45^11^1307 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,24,"N") ;;=23^25^27^26^27 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,25,"D") ;;=10^45^11^1305 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,25,"N") ;;=24^7^28^6^28 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,26,"D") ;;=8^66^8^1304 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,26,"N") ;;=19^27^24^23^24 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,27,"D") ;;=9^66^8^1308 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,27,"N") ;;=26^28^6^24^6 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,28,"D") ;;=10^66^8^1306 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,113,28,"N") ;;=27^7^7^25^7 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",2,"FIRST") ;;=2,113 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,0,0,"N") ;;=1,124^3,123^3,123^3,124^3,123 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,123) ;;=0^0^90002^^e^^^^3 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,123,3,"D") ;;=2^17^20^.01 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,123,3,"N") ;;=0^1,124^4^0^4 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,123,4,"D") ;;=2^45^25^.03 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,123,4,"N") ;;=0^2,124^1,124^3^1,124 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124) ;;=6^0^90002.01^^e^^6^^1^1 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124,1,"D") ;;=6^11^18^.01 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124,1,"N") ;;=3,123^0^0^4,123^0^1,-1^1,+1^2^3,-1^2 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124,2,"D") ;;=6^42^15^.04 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124,2,"N") ;;=3,123^0^0^1^0^2,-1^2,+1^3^1^3 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124,3,"D") ;;=6^70^4^.05 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,124,3,"N") ;;=4,123^0^0^2^0^3,-1^3,+1^1,+1^2^1,+1 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",3,"FIRST") ;;=3,123 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,0,0,"N") ;;=3,125^2,125^2,125^3,125^2,125 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,125) ;;=5^0^90002.01^^e^^^^2 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,125,2,"D") ;;=6^12^62^.06 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,125,2,"N") ;;=0^3^3^0^3 BCH1I003 BCH1I003 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,125,3,"D") ;;=7^26^3^.07 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,125,3,"N") ;;=2^0^0^2^0 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ",4,"FIRST") ;;=2,125 ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","# SERVED",1,1,31,11) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","ACTIVITY LOCATION",1,1,31,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","BP",2,2,113,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","CHR",3,3,123,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","DATE",2,2,113,18) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","DATE",2,2,113,23) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","DATE",2,2,113,24) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","DATE",2,2,113,25) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","DATE OF SERVICE",1,1,31,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","DATE OF SERVICE",3,3,123,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","EDIT ASSESSMENTS/POVS?",1,1,31,16) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","EDIT MEASUREMENTS/TESTS/REPROD?",1,1,31,15) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","EVALUATION",1,1,31,8) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","FP METHOD",2,2,113,15) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","HC",2,2,113,5) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","HLTH PROB",3,3,124,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","HOSPITAL/CLINIC NAME",1,1,31,6) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","HT",2,2,113,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","INSURER",1,1,31,14) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","LMP",2,2,113,14) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","NARRATIVE",4,4,125,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","OBJECTIVE",1,1,31,18) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","PLANS/TREATMENTS",1,1,31,19) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","PPD",2,2,113,16) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","PROGRAM",1,1,31,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","PROVIDER",1,1,31,5) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","PULSE",2,2,113,9) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","PURPOSE OF REFERRAL",1,1,31,13) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","REFERRED BY CHR TO",1,1,31,9) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","REFERRED TO CHR BY",1,1,31,7) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","RESP",2,2,113,10) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","RESULT",2,2,113,19) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","RESULT",2,2,113,26) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","RESULT",2,2,113,27) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","RESULT",2,2,113,28) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","SUBJECTIVE:",1,1,31,17) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","SUBSTANCE RELATED (Y/N)",4,4,125,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","SVC CODE",3,3,124,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","SVC MINS",3,3,124,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","TEMP",2,2,113,8) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","TEMP RESIDENCE",1,1,31,12) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","TRAVEL TIME",1,1,31,10) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","VC",2,2,113,7) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","VU",2,2,113,6) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","CAP","WT",2,2,113,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F0","15,31","L",1,31,15) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F0","16,31","L",1,31,16) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.01,"L",1,31,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.01,"L",3,123,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.02,"L",1,31,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.03,"L",1,31,5) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.03,"L",3,123,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.05,"L",1,31,6) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.06,"L",1,31,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.07,"L",1,31,7) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.08,"L",1,31,9) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.09,"L",1,31,8) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.11,"L",1,31,10) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.12,"L",1,31,11) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.13,"L",2,113,14) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",.14,"L",2,113,15) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1108,"L",1,31,12) ;;= BCH1I004 BCH1I004 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1201,"L",2,113,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1202,"L",2,113,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1203,"L",2,113,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1204,"L",2,113,5) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1205,"L",2,113,6) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1206,"L",2,113,7) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1207,"L",2,113,8) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1208,"L",2,113,9) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1209,"L",2,113,10) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1210,"L",2,113,16) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1301,"L",2,113,18) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1302,"L",2,113,19) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1303,"L",2,113,23) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1304,"L",2,113,26) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1305,"L",2,113,25) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1306,"L",2,113,28) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1307,"L",2,113,24) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",1308,"L",2,113,27) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",2101,"L",1,31,13) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",2102,"L",1,31,14) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",5101,"L",1,31,17) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",6101,"L",1,31,18) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002",7101,"L",1,31,19) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002.01",.01,"L",3,124,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002.01",.04,"L",3,124,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002.01",.05,"L",3,124,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002.01",.06,"L",4,125,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","F90002.01",.07,"L",4,125,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,0,6) ;;=********** E D I T C H R R E C O R D D A T A ********** ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,2,0) ;;=Date of Service: Program: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,2,0,"A") ;;=1;15;U^42;48;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,3,1) ;;=Temp Residence: Provider: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,3,1,"A") ;;=41;48;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,5,12) ;;=Edit Assessments/POVs?: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,7,17) ;;=Activity Location: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,7,17,"A") ;;=1;17;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,8,14) ;;=Hospital/Clinic Name: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,9,16) ;;=Referred to CHR by: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,10,16) ;;=Referred by CHR to: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,11,24) ;;=Evaluation: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,12,23) ;;=Travel Time: # Served: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,12,23,"A") ;;=1;11;U^24;31;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,13,15) ;;=Purpose of Referral: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,14,27) ;;=Insurer: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,15,3) ;;=Subjective:: Objective: Plans/Treatments: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",1,16,3) ;;=Edit Measurements/Tests/Reprod?: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,1,10) ;;=******* EDIT MEASUREMENTS/TEST/REPRODUCTIVE FACTORS ******* ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,3,3) ;;=** MEASUREMENTS ** ** TESTS ** ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,5,3) ;;=BP: PPD: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,6,3) ;;=WT: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,7,3) ;;=HT: BLOOD SUGAR Date: Result: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,8,3) ;;=HC: THRT CULT Date: Result: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,9,26) ;;=HCT Date: Result: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,10,3) ;;=VU: UA Date: Result: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,11,3) ;;=VC: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,13,3) ;;=TEMP: ** REPRODUCTIVE FACTORS ** ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,14,3) ;;=PULSE: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",2,15,3) ;;=RESP: LMP: FP METHOD: BCH1I005 BCH1I005 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,0,8) ;;=********* ASSESSMENT - PCC PURPOSE OF VISIT ********** ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,1,26) ;;=Enter/Edit Screen ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,2,0) ;;=Date of Service: CHR: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,2,0,"A") ;;=1;15;U^41;43;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,3,5) ;;=<> ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,4,0) ;;=--------------------------------------------------------------------------- ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,6,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,6,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,7,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,7,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,8,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,8,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,9,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,9,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,10,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,10,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,11,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",3,11,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",4,6,1) ;;=NARRATIVE: ;;^UTILITY(U,$J,"DIST(.403,",11,"AZ","X",4,7,1) ;;=SUBSTANCE RELATED (Y/N): ;;^UTILITY(U,$J,"DIST(.403,",12,0) ;;=BCH ENTER CHRIS II DATA^^^^2941117^^^90002^0^0^1 ;;^UTILITY(U,$J,"DIST(.403,",12,40,0) ;;=^.4031I^4^4 ;;^UTILITY(U,$J,"DIST(.403,",12,40,1,0) ;;=1^^1,1^^^0 ;;^UTILITY(U,$J,"DIST(.403,",12,40,1,1) ;;=ENTER CHRISS II DATA ;;^UTILITY(U,$J,"DIST(.403,",12,40,1,40,0) ;;=^.4032PI^32^1 ;;^UTILITY(U,$J,"DIST(.403,",12,40,1,40,32,0) ;;=BCH ENTER CHRIS II RECORD DATA^1^1,1^e ;;^UTILITY(U,$J,"DIST(.403,",12,40,1,40,"AC",1,32) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,1,40,"B",32,32) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,2,0) ;;=1.2^^9,14^^^1^14,54 ;;^UTILITY(U,$J,"DIST(.403,",12,40,2,1) ;;=Page 1.2 ;;^UTILITY(U,$J,"DIST(.403,",12,40,2,40,0) ;;=^.4032IP^110^1 ;;^UTILITY(U,$J,"DIST(.403,",12,40,2,40,110,0) ;;=BCH HOSP NAME^1^2,2^e ;;^UTILITY(U,$J,"DIST(.403,",12,40,2,40,"AC",1,110) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,2,40,"B",110,110) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,0) ;;=1.4^^1,1 ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,1) ;;=Page 1.4 ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,11) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,12) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,0) ;;=^.4032IP^124^2 ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,123,0) ;;=BCH POV HEADER BLOCK^1^1,1^e ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,124,0) ;;=BCH POV EDIT BLK^2^6,1^e ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,124,2) ;;=6^AD^n^0 ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,124,11) ;;=S BCHLOOK="" ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,124,12) ;;=K BCHLOOK ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,"AC",1,123) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,"AC",2,124) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,"B",123,123) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,3,40,"B",124,124) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,4,0) ;;=1.6^^9,1^^^1^13,76 ;;^UTILITY(U,$J,"DIST(.403,",12,40,4,1) ;;=Page 1.6 ;;^UTILITY(U,$J,"DIST(.403,",12,40,4,40,0) ;;=^.4032IP^125^1 ;;^UTILITY(U,$J,"DIST(.403,",12,40,4,40,125,0) ;;=BCH POV PROV NARR^1^2,2^e ;;^UTILITY(U,$J,"DIST(.403,",12,40,4,40,"AC",1,125) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,4,40,"B",125,125) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"B",1.2,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"B",1.4,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"B",1.6,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"C","ENTER CHRISS II DATA",1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"C","PAGE 1.2",2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"C","PAGE 1.4",3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,40,"C","PAGE 1.6",4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,0,0,"N") ;;=14,32^2,32^2,32^14,32^2,32 BCH1I006 BCH1I006 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32) ;;=0^0^90002^^e^^^^2 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,2,"D") ;;=1^17^20^.01 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,2,"N") ;;=0^5^3^0^3 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,3,"D") ;;=1^54^20^.02 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,3,"N") ;;=0^5^5^2^5 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,4,"D") ;;=7^15^20^.06 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,4,"N") ;;=16^7^7^16^7 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,5,"D") ;;=2^17^20^.03 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,5,"N") ;;=2^16^16^3^16 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,7,"D") ;;=8^15^8^.07 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,7,"N") ;;=4^9^8^4^8 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,8,"D") ;;=8^42^8^.08 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,8,"N") ;;=4^9^9^7^9 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,9,"D") ;;=9^12^50^.09 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,9,"N") ;;=7^10^10^8^10 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,10,"D") ;;=11^14^4^.11 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,10,"N") ;;=9^17^11^9^11 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,11,"D") ;;=11^32^5^.12 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,11,"N") ;;=9^18^12^10^12 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,12,"D") ;;=11^57^20^1108 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,12,"N") ;;=9^18^17^11^17 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,13,"D") ;;=15^14^60^2101 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,13,"N") ;;=17^14^14^19^14 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,14,"D") ;;=16^9^50^2102 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,14,"N") ;;=13^0^0^13^0 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,16,"D") ;;=5^48^1^16,32 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,16,"N") ;;=5^4^4^5^4 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,17,"D") ;;=13^12^1^5101 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,17,"N") ;;=10^13^18^12^18^^^^^^1 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,18,"D") ;;=13^32^1^6101 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,18,"N") ;;=11^13^19^17^19^^^^^^1 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,19,"D") ;;=13^58^1^7101 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,32,19,"N") ;;=12^13^13^18^13^^^^^^1 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",1,"FIRST") ;;=2,32 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",2,0,0,"N") ;;=1,110^1,110^1,110^1,110^1,110 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",2,110) ;;=9^14^90002^^e^^^^1 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",2,110,1,"D") ;;=12^16^30^.05 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",2,110,1,"N") ;;=0^0^0^0^0 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",2,"FIRST") ;;=1,110 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,0,0,"N") ;;=1,124^3,123^3,123^3,124^3,123 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,123) ;;=0^0^90002^^e^^^^3 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,123,3,"D") ;;=2^17^20^.01 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,123,3,"N") ;;=0^1,124^4^0^4 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,123,4,"D") ;;=2^45^25^.03 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,123,4,"N") ;;=0^2,124^1,124^3^1,124 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124) ;;=5^0^90002.01^^e^^6^^1^1 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124,1,"D") ;;=5^11^18^.01 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124,1,"N") ;;=3,123^0^0^4,123^0^1,-1^1,+1^2^3,-1^2 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124,2,"D") ;;=5^42^15^.04 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124,2,"N") ;;=3,123^0^0^1^0^2,-1^2,+1^3^1^3 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124,3,"D") ;;=5^70^4^.05 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,124,3,"N") ;;=4,123^0^0^2^0^3,-1^3,+1^1,+1^2^1,+1 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",3,"FIRST") ;;=3,123 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,0,0,"N") ;;=3,125^2,125^2,125^3,125^2,125 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,125) ;;=9^1^90002.01^^e^^^^2 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,125,2,"D") ;;=10^13^62^.06 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,125,2,"N") ;;=0^3^3^0^3 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,125,3,"D") ;;=11^27^3^.07 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,125,3,"N") ;;=2^0^0^2^0 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ",4,"FIRST") ;;=2,125 ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","# SERVED",1,1,32,11) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","ACT LOCATION",1,1,32,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","ASSESSMENT - PCC PURPOSE OF VISIT (HIT R",1,1,32,16) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","CHR",3,3,123,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","CHR PROVIDER",1,1,32,5) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","DATE OF SERVICE",1,1,32,2) ;;= BCH1I007 BCH1I007 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","DATE OF SERVICE",3,3,123,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","EVALUATION",1,1,32,9) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","HLTH PROB",3,3,124,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","INSURER",1,1,32,14) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","NARRATIVE",4,4,125,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","OBJECTIVE",1,1,32,18) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","PLANS/TREATMENTS",1,1,32,19) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","PROGRAM",1,1,32,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","PURPOSE REF",1,1,32,13) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","REF BY CHR TO",1,1,32,8) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","REF TO CHR BY",1,1,32,7) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","SUBJECTIVE",1,1,32,17) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","SUBSTANCE RELATED (Y/N)",4,4,125,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","SVC CODE",3,3,124,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","SVC MINS",3,3,124,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","TEMP RESIDENCE",1,1,32,12) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","CAP","TRAVEL TIME",1,1,32,10) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F0","16,32","L",1,32,16) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.01,"L",1,32,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.01,"L",3,123,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.02,"L",1,32,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.03,"L",1,32,5) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.03,"L",3,123,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.05,"L",2,110,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.06,"L",1,32,4) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.07,"L",1,32,7) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.08,"L",1,32,8) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.09,"L",1,32,9) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.11,"L",1,32,10) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",.12,"L",1,32,11) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",1108,"L",1,32,12) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",2101,"L",1,32,13) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",2102,"L",1,32,14) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",5101,"L",1,32,17) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",6101,"L",1,32,18) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002",7101,"L",1,32,19) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002.01",.01,"L",3,124,1) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002.01",.04,"L",3,124,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002.01",.05,"L",3,124,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002.01",.06,"L",4,125,2) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","F90002.01",.07,"L",4,125,3) ;;= ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,0,7) ;;=********** E N T E R C H R R E C O R D D A T A ********** ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,1,0) ;;=DATE OF SERVICE: PROGRAM: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,1,0,"A") ;;=1;15;U^40;46;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,2,0) ;;=CHR PROVIDER: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,2,0,"A") ;;=1;12;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,3,0) ;;=------------------------------------------------------------------------------- ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,5,0) ;;=ASSESSMENT - PCC PURPOSE OF VISIT (hit return): ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,7,0) ;;=ACT LOCATION: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,7,0,"A") ;;=1;12;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,8,0) ;;=REF TO CHR BY: REF BY CHR TO: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,9,0) ;;=EVALUATION: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,11,0) ;;=TRAVEL TIME: # SERVED: TEMP RESIDENCE: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,11,0,"A") ;;=1;11;U^22;29;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,13,0) ;;=SUBJECTIVE: OBJECTIVE: PLANS/TREATMENTS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,15,0) ;;=PURPOSE REF: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",1,16,0) ;;=INSURER: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",2,10,16) ;;=Enter the Hospital or Clinic Name ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,0,8) ;;=********* ASSESSMENT - PCC PURPOSE OF VISIT ********** ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,1,26) ;;=Enter/Edit Screen ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,2,0) ;;=Date of Service: CHR: BCH1I008 BCH1I008 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,2,0,"A") ;;=1;15;U^41;43;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,3,5) ;;=<> ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,4,0) ;;=--------------------------------------------------------------------------- ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,5,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,5,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,6,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,6,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,7,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,7,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,8,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,8,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,9,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,9,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,10,0) ;;=HLTH PROB: SVC CODE: SVC MINS: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",3,10,0,"A") ;;=1;9;U^33;40;U^61;68;U ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",4,10,2) ;;=NARRATIVE: ;;^UTILITY(U,$J,"DIST(.403,",12,"AZ","X",4,11,2) ;;=SUBSTANCE RELATED (Y/N): ;;^UTILITY(U,$J,"DIST(.404,",31,0) ;;=BCH EDIT RECORD DATA^90002 ;;^UTILITY(U,$J,"DIST(.404,",31,40,0) ;;=^.4044I^19^19 ;;^UTILITY(U,$J,"DIST(.404,",31,40,1,0) ;;=1^********** E D I T C H R R E C O R D D A T A **********^1^ ;;^UTILITY(U,$J,"DIST(.404,",31,40,1,2) ;;=^^1,7 ;;^UTILITY(U,$J,"DIST(.404,",31,40,2,0) ;;=2^Date of Service^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,2,1) ;;=.01 ;;^UTILITY(U,$J,"DIST(.404,",31,40,2,2) ;;=3,19^20^3,1 ;;^UTILITY(U,$J,"DIST(.404,",31,40,3,0) ;;=3^Program^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,3,1) ;;=.02 ;;^UTILITY(U,$J,"DIST(.404,",31,40,3,2) ;;=3,53^20^3,42 ;;^UTILITY(U,$J,"DIST(.404,",31,40,4,0) ;;=7^Activity Location^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,4,1) ;;=.06 ;;^UTILITY(U,$J,"DIST(.404,",31,40,4,2) ;;=8,38^20^8,18 ;;^UTILITY(U,$J,"DIST(.404,",31,40,4,4) ;;=1 ;;^UTILITY(U,$J,"DIST(.404,",31,40,5,0) ;;=5^Provider^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,5,1) ;;=.03 ;;^UTILITY(U,$J,"DIST(.404,",31,40,5,2) ;;=4,53^20^4,42 ;;^UTILITY(U,$J,"DIST(.404,",31,40,6,0) ;;=8^Hospital/Clinic Name^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,6,1) ;;=.05 ;;^UTILITY(U,$J,"DIST(.404,",31,40,6,2) ;;=9,38^20^9,15 ;;^UTILITY(U,$J,"DIST(.404,",31,40,6,4) ;;=0 ;;^UTILITY(U,$J,"DIST(.404,",31,40,7,0) ;;=9^Referred to CHR by^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,7,1) ;;=.07 ;;^UTILITY(U,$J,"DIST(.404,",31,40,7,2) ;;=10,38^20^10,17 ;;^UTILITY(U,$J,"DIST(.404,",31,40,8,0) ;;=11^Evaluation^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,8,1) ;;=.09 ;;^UTILITY(U,$J,"DIST(.404,",31,40,8,2) ;;=12,38^40^12,25 ;;^UTILITY(U,$J,"DIST(.404,",31,40,9,0) ;;=10^Referred by CHR to^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,9,1) ;;=.08 ;;^UTILITY(U,$J,"DIST(.404,",31,40,9,2) ;;=11,38^20^11,17 ;;^UTILITY(U,$J,"DIST(.404,",31,40,10,0) ;;=12^Travel Time^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,10,1) ;;=.11 ;;^UTILITY(U,$J,"DIST(.404,",31,40,10,2) ;;=13,38^6^13,24 ;;^UTILITY(U,$J,"DIST(.404,",31,40,11,0) ;;=13^# Served^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,11,1) ;;=.12 ;;^UTILITY(U,$J,"DIST(.404,",31,40,11,2) ;;=13,58^5^13,47 ;;^UTILITY(U,$J,"DIST(.404,",31,40,11,4) ;;=1 ;;^UTILITY(U,$J,"DIST(.404,",31,40,12,0) ;;=4^Temp Residence^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,12,1) ;;=1108 ;;^UTILITY(U,$J,"DIST(.404,",31,40,12,2) ;;=4,19^20^4,2 ;;^UTILITY(U,$J,"DIST(.404,",31,40,13,0) ;;=14^Purpose of Referral^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,13,1) ;;=2101 ;;^UTILITY(U,$J,"DIST(.404,",31,40,13,2) ;;=14,38^40^14,16 ;;^UTILITY(U,$J,"DIST(.404,",31,40,14,0) ;;=15^Insurer^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,14,1) ;;=2102 ;;^UTILITY(U,$J,"DIST(.404,",31,40,14,2) ;;=15,38^40^15,28 ;;^UTILITY(U,$J,"DIST(.404,",31,40,15,0) ;;=19^Edit Measurements/Tests/Reprod?^2 ;;^UTILITY(U,$J,"DIST(.404,",31,40,15,2) ;;=17,38^1^17,4 ;;^UTILITY(U,$J,"DIST(.404,",31,40,15,3) ;;=N ;;^UTILITY(U,$J,"DIST(.404,",31,40,15,10) ;;=I X="Y" S DDSSTACK="Page 1.2" BCH1I009 BCH1I009 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.404,",31,40,15,20) ;;=F ;;^UTILITY(U,$J,"DIST(.404,",31,40,16,0) ;;=6^Edit Assessments/POVs?^2 ;;^UTILITY(U,$J,"DIST(.404,",31,40,16,2) ;;=6,38^1^6,13 ;;^UTILITY(U,$J,"DIST(.404,",31,40,16,3) ;;=N ;;^UTILITY(U,$J,"DIST(.404,",31,40,16,10) ;;=I X="Y" S DDSSTACK="Page 1.4" ;;^UTILITY(U,$J,"DIST(.404,",31,40,16,20) ;;=S^^Y:YES;N:NO ;;^UTILITY(U,$J,"DIST(.404,",31,40,17,0) ;;=16^Subjective:^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,17,1) ;;=5101 ;;^UTILITY(U,$J,"DIST(.404,",31,40,17,2) ;;=16,17^1^16,4 ;;^UTILITY(U,$J,"DIST(.404,",31,40,18,0) ;;=17^Objective^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,18,1) ;;=6101 ;;^UTILITY(U,$J,"DIST(.404,",31,40,18,2) ;;=16,36^1^16,25 ;;^UTILITY(U,$J,"DIST(.404,",31,40,19,0) ;;=18^Plans/Treatments^3 ;;^UTILITY(U,$J,"DIST(.404,",31,40,19,1) ;;=7101 ;;^UTILITY(U,$J,"DIST(.404,",31,40,19,2) ;;=16,61^1^16,43 ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",2,2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",3,3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",4,12) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",5,5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",6,16) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",7,4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",8,6) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",9,7) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",10,9) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",11,8) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",12,10) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",13,11) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",14,13) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",15,14) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",16,17) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",17,18) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",18,19) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"B",19,15) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","# SERVED",11) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","********** E D I T C H R R E C O R D D A T A *********",1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","ACTIVITY LOCATION",4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","DATE OF SERVICE",2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","EDIT ASSESSMENTS/POVS?",16) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","EDIT MEASUREMENTS/TESTS/REPROD?",15) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","EVALUATION",8) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","HOSPITAL/CLINIC NAME",6) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","INSURER",14) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","OBJECTIVE",18) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","PLANS/TREATMENTS",19) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","PROGRAM",3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","PROVIDER",5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","PURPOSE OF REFERRAL",13) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","REFERRED BY CHR TO",9) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","REFERRED TO CHR BY",7) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","SUBJECTIVE:",17) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","TEMP RESIDENCE",12) ;;= ;;^UTILITY(U,$J,"DIST(.404,",31,40,"C","TRAVEL TIME",10) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,0) ;;=BCH ENTER CHRIS II RECORD DATA^90002 ;;^UTILITY(U,$J,"DIST(.404,",32,40,0) ;;=^.4044I^19^18 ;;^UTILITY(U,$J,"DIST(.404,",32,40,1,0) ;;=1^********** E N T E R C H R R E C O R D D A T A **********^1^ ;;^UTILITY(U,$J,"DIST(.404,",32,40,1,2) ;;=^^1,8 ;;^UTILITY(U,$J,"DIST(.404,",32,40,2,0) ;;=2^DATE OF SERVICE^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,2,1) ;;=.01 ;;^UTILITY(U,$J,"DIST(.404,",32,40,2,2) ;;=2,18^20^2,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,2,4) ;;=^^^1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,3,0) ;;=3^PROGRAM^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,3,1) ;;=.02 ;;^UTILITY(U,$J,"DIST(.404,",32,40,3,2) ;;=2,55^20^2,40 ;;^UTILITY(U,$J,"DIST(.404,",32,40,3,4) ;;=^^^1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,4,0) ;;=7^ACT LOCATION^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,4,1) ;;=.06 ;;^UTILITY(U,$J,"DIST(.404,",32,40,4,2) ;;=8,16^20^8,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,4,4) ;;=1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,4,10) ;;=S:X=4 DDSSTACK="Page 1.2" ;;^UTILITY(U,$J,"DIST(.404,",32,40,5,0) ;;=4^CHR PROVIDER^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,5,1) ;;=.03 ;;^UTILITY(U,$J,"DIST(.404,",32,40,5,2) ;;=3,18^20^3,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,5,4) ;;=^^^1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,7,0) ;;=8^REF TO CHR BY^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,7,1) ;;=.07 ;;^UTILITY(U,$J,"DIST(.404,",32,40,7,2) ;;=9,16^8^9,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,8,0) ;;=9^REF BY CHR TO^3 BCH1I00A BCH1I00A ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.404,",32,40,8,1) ;;=.08 ;;^UTILITY(U,$J,"DIST(.404,",32,40,8,2) ;;=9,43^8^9,28 ;;^UTILITY(U,$J,"DIST(.404,",32,40,9,0) ;;=10^EVALUATION^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,9,1) ;;=.09 ;;^UTILITY(U,$J,"DIST(.404,",32,40,9,2) ;;=10,13^50^10,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,10,0) ;;=11^TRAVEL TIME^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,10,1) ;;=.11 ;;^UTILITY(U,$J,"DIST(.404,",32,40,10,2) ;;=12,15^4^12,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,11,0) ;;=12^# SERVED^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,11,1) ;;=.12 ;;^UTILITY(U,$J,"DIST(.404,",32,40,11,2) ;;=12,33^5^12,22 ;;^UTILITY(U,$J,"DIST(.404,",32,40,11,3) ;;=1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,11,4) ;;=1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,12,0) ;;=13^TEMP RESIDENCE^3^ ;;^UTILITY(U,$J,"DIST(.404,",32,40,12,1) ;;=1108 ;;^UTILITY(U,$J,"DIST(.404,",32,40,12,2) ;;=12,58^20^12,41 ;;^UTILITY(U,$J,"DIST(.404,",32,40,13,0) ;;=17^PURPOSE REF^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,13,1) ;;=2101 ;;^UTILITY(U,$J,"DIST(.404,",32,40,13,2) ;;=16,15^60^16,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,14,0) ;;=18^INSURER^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,14,1) ;;=2102 ;;^UTILITY(U,$J,"DIST(.404,",32,40,14,2) ;;=17,10^50^17,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,15,0) ;;=5^-------------------------------------------------------------------------------^1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,15,2) ;;=^^4,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,16,0) ;;=6^ASSESSMENT - PCC PURPOSE OF VISIT (hit return)^2 ;;^UTILITY(U,$J,"DIST(.404,",32,40,16,2) ;;=6,49^1^6,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,16,10) ;;=S DDSSTACK="Page 1.4" ;;^UTILITY(U,$J,"DIST(.404,",32,40,16,20) ;;=F^^1:1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,17,0) ;;=14^SUBJECTIVE^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,17,1) ;;=5101 ;;^UTILITY(U,$J,"DIST(.404,",32,40,17,2) ;;=14,13^1^14,1 ;;^UTILITY(U,$J,"DIST(.404,",32,40,18,0) ;;=15^OBJECTIVE^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,18,1) ;;=6101 ;;^UTILITY(U,$J,"DIST(.404,",32,40,18,2) ;;=14,33^1^14,22 ;;^UTILITY(U,$J,"DIST(.404,",32,40,19,0) ;;=16^PLANS/TREATMENTS^3 ;;^UTILITY(U,$J,"DIST(.404,",32,40,19,1) ;;=7101 ;;^UTILITY(U,$J,"DIST(.404,",32,40,19,2) ;;=14,59^1^14,41 ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",2,2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",3,3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",4,5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",5,15) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",6,16) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",7,4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",8,7) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",9,8) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",10,9) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",11,10) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",12,11) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",13,12) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",14,17) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",15,18) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",16,19) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",17,13) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"B",18,14) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","# SERVED",11) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","********** E N T E R C H R R E C O R D D A T A **********",1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","---------------------------------------------------------------",15) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","ACT LOCATION",4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","ASSESSMENT - PCC PURPOSE OF VISIT (HIT RETURN)",16) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","CHR PROVIDER",5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","DATE OF SERVICE",2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","EVALUATION",9) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","INSURER",14) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","OBJECTIVE",18) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","PLANS/TREATMENTS",19) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","PROGRAM",3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","PURPOSE REF",13) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","REF BY CHR TO",8) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","REF TO CHR BY",7) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","SUBJECTIVE",17) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","TEMP RESIDENCE",12) ;;= ;;^UTILITY(U,$J,"DIST(.404,",32,40,"C","TRAVEL TIME",10) ;;= ;;^UTILITY(U,$J,"DIST(.404,",110,0) ;;=BCH HOSP NAME^90002 ;;^UTILITY(U,$J,"DIST(.404,",110,40,0) ;;=^.4044I^2^2 ;;^UTILITY(U,$J,"DIST(.404,",110,40,1,0) ;;=1^^3 ;;^UTILITY(U,$J,"DIST(.404,",110,40,1,1) ;;=.05 BCH1I00B BCH1I00B ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.404,",110,40,1,2) ;;=4,3^30 ;;^UTILITY(U,$J,"DIST(.404,",110,40,2,0) ;;=2^Enter the Hospital or Clinic Name^1 ;;^UTILITY(U,$J,"DIST(.404,",110,40,2,2) ;;=^^2,3 ;;^UTILITY(U,$J,"DIST(.404,",110,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",110,40,"B",2,2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",110,40,"C","ENTER THE HOSPITAL OR CLINIC NAME",2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,0) ;;=BCH EDIT TESTS/MSR/RF^90002 ;;^UTILITY(U,$J,"DIST(.404,",113,40,0) ;;=^.4044I^28^28 ;;^UTILITY(U,$J,"DIST(.404,",113,40,1,0) ;;=1^******* EDIT MEASUREMENTS/TEST/REPRODUCTIVE FACTORS *******^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,1,2) ;;=^^1,9 ;;^UTILITY(U,$J,"DIST(.404,",113,40,2,0) ;;=4^BP^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,2,1) ;;=1201 ;;^UTILITY(U,$J,"DIST(.404,",113,40,2,2) ;;=5,9^10^5,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,3,0) ;;=6^WT^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,3,1) ;;=1202 ;;^UTILITY(U,$J,"DIST(.404,",113,40,3,2) ;;=6,9^10^6,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,4,0) ;;=7^HT^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,4,1) ;;=1203 ;;^UTILITY(U,$J,"DIST(.404,",113,40,4,2) ;;=7,9^10^7,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,5,0) ;;=11^HC^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,5,1) ;;=1204 ;;^UTILITY(U,$J,"DIST(.404,",113,40,5,2) ;;=8,9^10^8,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,6,0) ;;=18^VU^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,6,1) ;;=1205 ;;^UTILITY(U,$J,"DIST(.404,",113,40,6,2) ;;=10,9^10^10,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,7,0) ;;=22^VC^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,7,1) ;;=1206 ;;^UTILITY(U,$J,"DIST(.404,",113,40,7,2) ;;=11,9^10^11,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,8,0) ;;=23^TEMP^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,8,1) ;;=1207 ;;^UTILITY(U,$J,"DIST(.404,",113,40,8,2) ;;=13,9^10^13,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,9,0) ;;=25^PULSE^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,9,1) ;;=1208 ;;^UTILITY(U,$J,"DIST(.404,",113,40,9,2) ;;=14,9^10^14,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,10,0) ;;=26^RESP^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,10,1) ;;=1209 ;;^UTILITY(U,$J,"DIST(.404,",113,40,10,2) ;;=15,9^10^15,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,11,0) ;;=2^** MEASUREMENTS **^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,11,2) ;;=^^3,2 ;;^UTILITY(U,$J,"DIST(.404,",113,40,12,0) ;;=3^** TESTS **^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,12,2) ;;=^^3,39 ;;^UTILITY(U,$J,"DIST(.404,",113,40,13,0) ;;=24^** REPRODUCTIVE FACTORS **^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,13,2) ;;=^^13,33 ;;^UTILITY(U,$J,"DIST(.404,",113,40,14,0) ;;=27^LMP^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,14,1) ;;=.13 ;;^UTILITY(U,$J,"DIST(.404,",113,40,14,2) ;;=15,33^11^15,28 ;;^UTILITY(U,$J,"DIST(.404,",113,40,15,0) ;;=28^FP METHOD^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,15,1) ;;=.14 ;;^UTILITY(U,$J,"DIST(.404,",113,40,15,2) ;;=15,58^5^15,47 ;;^UTILITY(U,$J,"DIST(.404,",113,40,16,0) ;;=5^PPD^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,16,1) ;;=1210 ;;^UTILITY(U,$J,"DIST(.404,",113,40,16,2) ;;=5,30^11^5,25 ;;^UTILITY(U,$J,"DIST(.404,",113,40,17,0) ;;=8^BLOOD SUGAR^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,17,2) ;;=^^7,25 ;;^UTILITY(U,$J,"DIST(.404,",113,40,18,0) ;;=9^Date^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,18,1) ;;=1301 ;;^UTILITY(U,$J,"DIST(.404,",113,40,18,2) ;;=7,44^11^7,38 ;;^UTILITY(U,$J,"DIST(.404,",113,40,19,0) ;;=10^Result^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,19,1) ;;=1302 ;;^UTILITY(U,$J,"DIST(.404,",113,40,19,2) ;;=7,65^8^7,57 ;;^UTILITY(U,$J,"DIST(.404,",113,40,20,0) ;;=12^THRT CULT^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,20,2) ;;=^^8,25 ;;^UTILITY(U,$J,"DIST(.404,",113,40,21,0) ;;=15^HCT^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,21,2) ;;=^^9,25 ;;^UTILITY(U,$J,"DIST(.404,",113,40,22,0) ;;=19^UA^1 ;;^UTILITY(U,$J,"DIST(.404,",113,40,22,2) ;;=^^10,25 ;;^UTILITY(U,$J,"DIST(.404,",113,40,23,0) ;;=13^Date^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,23,1) ;;=1303 ;;^UTILITY(U,$J,"DIST(.404,",113,40,23,2) ;;=8,44^11^8,38 ;;^UTILITY(U,$J,"DIST(.404,",113,40,24,0) ;;=16^Date^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,24,1) ;;=1307 ;;^UTILITY(U,$J,"DIST(.404,",113,40,24,2) ;;=9,44^11^9,38 ;;^UTILITY(U,$J,"DIST(.404,",113,40,25,0) ;;=20^Date^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,25,1) ;;=1305 ;;^UTILITY(U,$J,"DIST(.404,",113,40,25,2) ;;=10,44^11^10,38 ;;^UTILITY(U,$J,"DIST(.404,",113,40,26,0) ;;=14^Result^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,26,1) ;;=1304 ;;^UTILITY(U,$J,"DIST(.404,",113,40,26,2) ;;=8,65^8^8,57 ;;^UTILITY(U,$J,"DIST(.404,",113,40,27,0) ;;=17^Result^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,27,1) ;;=1308 ;;^UTILITY(U,$J,"DIST(.404,",113,40,27,2) ;;=9,65^8^9,57 BCH1I00C BCH1I00C ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.404,",113,40,28,0) ;;=21^Result^3 ;;^UTILITY(U,$J,"DIST(.404,",113,40,28,1) ;;=1306 ;;^UTILITY(U,$J,"DIST(.404,",113,40,28,2) ;;=10,65^8^10,57 ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",2,11) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",3,12) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",4,2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",5,16) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",6,3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",7,4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",8,17) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",9,18) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",10,19) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",11,5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",12,20) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",13,23) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",14,26) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",15,21) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",16,24) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",17,27) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",18,6) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",19,22) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",20,25) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",21,28) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",22,7) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",23,8) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",24,13) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",25,9) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",26,10) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",27,14) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"B",28,15) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","** MEASUREMENTS **",11) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","** REPRODUCTIVE FACTORS **",13) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","** TESTS **",12) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","******* EDIT MEASUREMENTS/TEST/REPRODUCTIVE FACTORS *******",1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","BLOOD SUGAR",17) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","BP",2) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","DATE",18) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","DATE",23) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","DATE",24) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","DATE",25) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","FP METHOD",15) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","HC",5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","HCT",21) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","HT",4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","LMP",14) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","PPD",16) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","PULSE",9) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","RESP",10) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","RESULT",19) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","RESULT",26) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","RESULT",27) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","RESULT",28) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","TEMP",8) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","THRT CULT",20) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","UA",22) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","VC",7) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","VU",6) ;;= ;;^UTILITY(U,$J,"DIST(.404,",113,40,"C","WT",3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,0) ;;=BCH POV HEADER BLOCK^90002 ;;^UTILITY(U,$J,"DIST(.404,",123,40,0) ;;=^.4044I^6^6 ;;^UTILITY(U,$J,"DIST(.404,",123,40,1,0) ;;=1^********* ASSESSMENT - PCC PURPOSE OF VISIT **********^1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,1,2) ;;=^^1,9 ;;^UTILITY(U,$J,"DIST(.404,",123,40,2,0) ;;=2^Enter/Edit Screen^1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,2,2) ;;=^^2,27 ;;^UTILITY(U,$J,"DIST(.404,",123,40,3,0) ;;=3^Date of Service^3 ;;^UTILITY(U,$J,"DIST(.404,",123,40,3,1) ;;=.01 ;;^UTILITY(U,$J,"DIST(.404,",123,40,3,2) ;;=3,18^20^3,1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,3,4) ;;=^^^1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,4,0) ;;=4^CHR^3 ;;^UTILITY(U,$J,"DIST(.404,",123,40,4,1) ;;=.03 ;;^UTILITY(U,$J,"DIST(.404,",123,40,4,2) ;;=3,46^25^3,41 ;;^UTILITY(U,$J,"DIST(.404,",123,40,4,4) ;;=^^^1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,5,0) ;;=5^---------------------------------------------------------------------------^1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,5,2) ;;=^^5,1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,6,0) ;;=6^<>^1 ;;^UTILITY(U,$J,"DIST(.404,",123,40,6,2) ;;=^^4,6 ;;^UTILITY(U,$J,"DIST(.404,",123,40,"B",1,1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"B",2,2) ;;= BCH1I00D BCH1I00D ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"DIST(.404,",123,40,"B",3,3) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"B",4,4) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"B",5,5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"B",6,6) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"C","********* ASSESSMENT - PCC PURPOSE OF VISIT **********",1) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"C","---------------------------------------------------------------",5) ;;= ;;^UTILITY(U,$J,"DIST(.404,",123,40,"C","<0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD S DN="^BCH1I" F R=1:1:13 D @(DN_$$B36(R)) W "." F S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0 K ^(D) D IX DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA ; W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0)) S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W S:%=2 DIFQ(X)=0 K:%<0 DIFQ Q ; OPT ;OPTION RTN ;ROUTINE DOCUMENTATION NOTE FUN ;FUNCTION BUL ;BULLETIN KEY ;SECURITY KEY HEL ;HELP FRAME DIP ;PRINT TEMPLATE DIE ;INPUT TEMPLATE DIB ;SORT TEMPLATE DIS ;FORM ; SBF ;FILE AND SUB FILE NUMBERS IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK Q B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1) N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) BCH1INI2 BCH1INI2 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD Q ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0 S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR S DIK=DIC HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R="" W !,"'"_R_"' Help Frame filed." S DA=^(R) F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99) S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0) I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I IX D IX1^DIK G HELP ; U I $D(DIRUT) S DIFQ=1 W ! Q REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT) I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q S DIR("A")="Shall I replace your file with mine" S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y S DIU(0)="E",DIR("A")="Do you want to keep the Data" S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"D" S DIR("A")="Do you want to keep the Templates" S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T" S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q BCH1INI3 BCH1INI3 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0)) S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins." I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=% OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^BCH1INI4 NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J) I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD S DIC=.5,DLAYGO=0,N="FUN" D ADD S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ K ^UTILITY("DIFROM",$J) Q DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII E S DISYS=^DD("OS") Q:'$D(^DD("OS",DISYS,"ZS")) S DIFR1="" DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1="" F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") G DZ1 ; OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=% S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C") F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A Q Q A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0)) K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^") I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%) I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!" .Q I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1) I N="DIST(.403," D BLK S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT I N="DIST(.403," D .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA) .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled" .Q Q BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1 K A0,A1,A2,J,L Q B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X) .Q S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X) .Q S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK") Q KAD(D0) N D1,X S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1) Q BCH1INI4 BCH1INI4 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ; EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_"," S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1) D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4) I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=% D OR S DA(1)=1 D IX1^DIK Q OR S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J Q OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J Q ADDP N I,J,N,R,DA,DLAYGO S %="" S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q BCH1INI5 BCH1INI5 ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:0 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1 Q IXF ;;IHS RPMS CHR SYSTEM PATCH 1^BCH1 BCH1INIS BCH1INIS ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 PAC(PKG,VER) ; called from package init (DIFROM7 created this routine) ; PKG = $T(IXF) of the INIT routine. ; VER is an array that is contained in DIFROM from the INIT routine ; N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("BCH1INIS",$J) ; ; Site tracking updates only occur if run in a VA production primary domain ; account. I $G(^XMB("NETNAME"))'[".VA.GOV" Q Q:'$D(^%ZOSF("UCI")) Q:'$D(^%ZOSF("PROD")) X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q ; S SERVER="S.A5CSTS@FORUM.VA.GOV" S PACKAGE=$P($P(PKG,";",3),U) S SITE=$G(^XMB("NETNAME")) S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown" D ; check if ok to use kernel functions .S X="XLFDT" X ^%ZOSF("TEST") I $T D Q ..S NOW=$$HTFM^XLFDT($H) ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3) ..S START=$$FMTE^XLFDT(START) ..S DATE=NOW\1 ..S NOW=$$FMTE^XLFDT(NOW) .D NOW^%DTC S NOW=%,DATE=X .S RUN="" ; don't bother to compute .S Y=START D DD^%DT S START=Y .S Y=NOW D DD^%DT S NOW=Y ; ; Message for server S ^TMP("BCH1INIS",$J,1,0)="PACKAGE INSTALL" S ^TMP("BCH1INIS",$J,2,0)="SITE: "_SITE S ^TMP("BCH1INIS",$J,3,0)="PACKAGE: "_PACKAGE S ^TMP("BCH1INIS",$J,4,0)="VERSION: "_VER S ^TMP("BCH1INIS",$J,5,0)="Start time: "_START S ^TMP("BCH1INIS",$J,6,0)="Completion time: "_NOW S ^TMP("BCH1INIS",$J,7,0)="Run time: "_RUN S ^TMP("BCH1INIS",$J,8,0)="DATE: "_DATE ; ; Data is sent to server on FORUM - S.A5CSTS S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""BCH1INIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION" D ^XMD K ^TMP("BCH1INIS",$J) Q BCH1INIT BCH1INIT ; IHS/TUCSON/LAB - NO DESCRIPTION PROVIDED ; ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT S DIOVRD=1,U="^",DIFQ=0,DIFROM="1.0" W !,"This version (#1.0) of 'BCH1INIT' was created on 03-JUN-1997" W !?9,"(at TUCSON DEVELOPMENT 486 SCO-BOX, by VA FileMan V.21.0)",! I $D(^DD("VERSION")),^("VERSION")'<21 G GO ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q GO ; EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM S DIFQ=0 K DIRUT,DTOUT,DUOUT F DIFRIR=1:1:1 S DIFRRTN="^BCH1INI"_$E("5",DIFRIR) D @DIFRRTN W:0 !,"I AM GOING TO SET UP THE FOLLOWING FILE:" F I=1:2:0 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I) S DIFROM="1.0" D PKG:'$D(DIFROM(0)),^BCH1INI1 G Q:'$D(DIFQ) S DIK(0)="AB" F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) K DIFQR D ^BCH1INI2,^BCH1INI3 L S DUZ=DIDUZ W:0 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE" I DIFROM F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN I DIFROM,$D(^%ZTSK) S X="BCH1INIS" X ^%ZOSF("TEST") D:$T PAC^BCH1INIS($T(IXF),.DIFROM) S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." Q R G REP^BCH1INI2 ; 1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 S DIFQ(N)=$P(DIF(I),";",7)'="n" I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 Q Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ; PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC Q ; IXF ;;IHS RPMS CHR SYSTEM PATCH 1^BCH1;6 BCH2I001 BCH2I001 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 Q:'DIFQ(90002.01) F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^DIC(90002.01,0,"GL") ;;=^BCHRPROB( ;;^DIC("B","CHR POV",90002.01) ;;= ;;^DIC(90002.01,"%D",0) ;;=^^1^1^2950201^ ;;^DIC(90002.01,"%D",1,0) ;;=This file contains one record for each assessment on the CHR PCC Form. ;;^DD(90002.01,0) ;;=FIELD^^.07^7 ;;^DD(90002.01,0,"DT") ;;=2970626 ;;^DD(90002.01,0,"ID",.02) ;;=W "" ;;^DD(90002.01,0,"ID",.03) ;;=S %I=Y,Y=$S('$D(^(0)):"",$D(^BCHR(+$P(^(0),U,3),0))#2:$P(^(0),U,1),1:""),C=$P(^DD(90002,.01,0),U,2) D Y^DIQ:Y]"" W " ",Y,@("$E("_DIC_"%I,0),0)") S Y=%I K %I ;;^DD(90002.01,0,"IX","AC",90002.01,.02) ;;= ;;^DD(90002.01,0,"IX","AD",90002.01,.03) ;;= ;;^DD(90002.01,0,"IX","AY9",90002.01,.01) ;;= ;;^DD(90002.01,0,"IX","B",90002.01,.01) ;;= ;;^DD(90002.01,0,"NM","CHR POV") ;;= ;;^DD(90002.01,.01,0) ;;=PROBLEM CODE^RP90002.53'^BCHTPROB(^0;1^Q ;;^DD(90002.01,.01,1,0) ;;=^.1 ;;^DD(90002.01,.01,1,1,0) ;;=90002.01^B ;;^DD(90002.01,.01,1,1,1) ;;=S ^BCHRPROB("B",$E(X,1,30),DA)="" ;;^DD(90002.01,.01,1,1,2) ;;=K ^BCHRPROB("B",$E(X,1,30),DA) ;;^DD(90002.01,.01,1,2,0) ;;=90002.01^AY9^MUMPS ;;^DD(90002.01,.01,1,2,1) ;;=S:$D(BCHLOOK) DIC("DR")="" ;;^DD(90002.01,.01,1,2,2) ;;=Q ;;^DD(90002.01,.01,1,2,"%D",0) ;;=^^1^1^2950201^ ;;^DD(90002.01,.01,1,2,"%D",1,0) ;;=Sets DIC("DR") to prevent the asking of identifiers when file shifting. ;;^DD(90002.01,.01,1,2,"DT") ;;=2940916 ;;^DD(90002.01,.01,3) ;;= ;;^DD(90002.01,.01,"DT") ;;=2940916 ;;^DD(90002.01,.05,0) ;;=SERVICE MINUTES^RNJ4,0^^0;5^K:+X'=X!(X>9999)!(X<0)!(X?.E1"."1N.N) X ;;^DD(90002.01,.05,1,0) ;;=^.1 ;;^DD(90002.01,.05,1,1,0) ;;=^^TRIGGER^90002^.27 ;;^DD(90002.01,.05,1,1,1) ;;=K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(90002.01,.05,1,1,89.2) S X=$P(Y(101),U,27) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(90002.01,.05,1,1,1.4) ;;^DD(90002.01,.05,1,1,1.4) ;;=S DIH=$S($D(^BCHR(DIV(0),0)):^(0),1:""),DIV=X I $D(^(0)) S $P(^(0),U,27)=DIV,DIH=90002,DIG=.27 D ^DICR:$O(^DD(DIH,DIG,1,0))>0 ;;^DD(90002.01,.05,1,1,2) ;;=K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(90002.01,.05,1,1,89.2) S X=$P(Y(101),U,27) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(90002.01,.05,1,1,2.4) ;;^DD(90002.01,.05,1,1,2.4) ;;=S DIH=$S($D(^BCHR(DIV(0),0)):^(0),1:""),DIV=X I $D(^(0)) S $P(^(0),U,27)=DIV,DIH=90002,DIG=.27 D ^DICR:$O(^DD(DIH,DIG,1,0))>0 ;;^DD(90002.01,.05,1,1,89.2) ;;=S I(0,0)=$S($D(D0):D0,1:""),Y(1)=$S($D(^BCHRPROB(D0,0)):^(0),1:""),D0=$P(Y(1),U,3) S:'$D(^BCHR(+D0,0)) D0=-1 S DIV(0)=D0 S Y(101)=$S($D(^BCHR(D0,0)):^(0),1:"") ;;^DD(90002.01,.05,1,1,"CREATE VALUE") ;;=TOTAL SERVICE TIME+SERVICE MINUTES ;;^DD(90002.01,.05,1,1,"DELETE VALUE") ;;=TOTAL SERVICE TIME-OLD SERVICE MINUTES ;;^DD(90002.01,.05,1,1,"DT") ;;=2950112 ;;^DD(90002.01,.05,1,1,"FIELD") ;;=#.03:#.27 ;;^DD(90002.01,.05,3) ;;=Type a Number between 0 and 9999, 0 Decimal Digits ;;^DD(90002.01,.05,"DT") ;;=2970626 BCH2I002 BCH2I002 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"PKG",418,0) ;;=BCH2-CHR SYSTEM PATCH 3^BCH2^BCH2-CHR SYSTEM PATCH 3 ;;^UTILITY(U,$J,"PKG",418,4,0) ;;=^9.44PA^1^1 ;;^UTILITY(U,$J,"PKG",418,4,1,0) ;;=90002.01 ;;^UTILITY(U,$J,"PKG",418,4,1,1,0) ;;=^9.45A^1^1 ;;^UTILITY(U,$J,"PKG",418,4,1,1,1,0) ;;=SERVICE MINUTES ;;^UTILITY(U,$J,"PKG",418,4,1,1,"B","SERVICE MINUTES",1) ;;= ;;^UTILITY(U,$J,"PKG",418,4,1,222) ;;=y^n^^n^^^n ;;^UTILITY(U,$J,"PKG",418,4,"B",90002.01,1) ;;= ;;^UTILITY(U,$J,"PKG",418,22,0) ;;=^9.49I^1^1 ;;^UTILITY(U,$J,"PKG",418,22,1,0) ;;=1.0^2970626 ;;^UTILITY(U,$J,"PKG",418,22,"B","1.0",1) ;;= ;;^UTILITY(U,$J,"SBF",90002.01,90002.01) ;;= BCH2INI1 BCH2INI1 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 ; LOADS AND INDEXES DD'S ; K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q Q:'$D(DIFQ) S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD S DN="^BCH2I" F R=1:1:2 D @(DN_$$B36(R)) W "." F S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0 K ^(D) D IX DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA ; W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0)) S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W S:%=2 DIFQ(X)=0 K:%<0 DIFQ Q ; OPT ;OPTION RTN ;ROUTINE DOCUMENTATION NOTE FUN ;FUNCTION BUL ;BULLETIN KEY ;SECURITY KEY HEL ;HELP FRAME DIP ;PRINT TEMPLATE DIE ;INPUT TEMPLATE DIB ;SORT TEMPLATE DIS ;FORM ; SBF ;FILE AND SUB FILE NUMBERS IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK Q B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1) N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) BCH2INI2 BCH2INI2 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 ; ; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD Q ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0 S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR S DIK=DIC HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R="" W !,"'"_R_"' Help Frame filed." S DA=^(R) F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99) S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0) I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I IX D IX1^DIK G HELP ; U I $D(DIRUT) S DIFQ=1 W ! Q REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT) I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q S DIR("A")="Shall I replace your file with mine" S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y S DIU(0)="E",DIR("A")="Do you want to keep the Data" S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"D" S DIR("A")="Do you want to keep the Templates" S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T" S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q BCH2INI3 BCH2INI3 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 ; ; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0)) S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins." I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=% OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^BCH2INI4 NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J) I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD S DIC=.5,DLAYGO=0,N="FUN" D ADD S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ K ^UTILITY("DIFROM",$J) Q DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII E S DISYS=^DD("OS") Q:'$D(^DD("OS",DISYS,"ZS")) S DIFR1="" DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1="" F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") G DZ1 ; OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=% S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C") F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A Q Q A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0)) K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^") I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%) I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!" .Q I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1) I N="DIST(.403," D BLK S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT I N="DIST(.403," D .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA) .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled" .Q Q BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1 K A0,A1,A2,J,L Q B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X) .Q S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X) .Q S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK") Q KAD(D0) N D1,X S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1) Q BCH2INI4 BCH2INI4 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 ; ; EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_"," S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1) D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4) I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=% D OR S DA(1)=1 D IX1^DIK Q OR S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J Q OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J Q ADDP N I,J,N,R,DA,DLAYGO S %="" S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q BCH2INI5 BCH2INI5 ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:2 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1 Q IXF ;;BCH2-CHR SYSTEM PATCH 3^BCH2 ;;90002.01API;CHR POV;^BCHRPROB(;1;y;n;;n;;;n ;; BCH2INIS BCH2INIS ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 PAC(PKG,VER) ; called from package init (DIFROM7 created this routine) ; PKG = $T(IXF) of the INIT routine. ; VER is an array that is contained in DIFROM from the INIT routine ; N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("BCH2INIS",$J) ; ; Site tracking updates only occur if run in a VA production primary domain ; account. I $G(^XMB("NETNAME"))'[".VA.GOV" Q Q:'$D(^%ZOSF("UCI")) Q:'$D(^%ZOSF("PROD")) X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q ; S SERVER="S.A5CSTS@FORUM.VA.GOV" S PACKAGE=$P($P(PKG,";",3),U) S SITE=$G(^XMB("NETNAME")) S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown" D ; check if ok to use kernel functions .S X="XLFDT" X ^%ZOSF("TEST") I $T D Q ..S NOW=$$HTFM^XLFDT($H) ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3) ..S START=$$FMTE^XLFDT(START) ..S DATE=NOW\1 ..S NOW=$$FMTE^XLFDT(NOW) .D NOW^%DTC S NOW=%,DATE=X .S RUN="" ; don't bother to compute .S Y=START D DD^%DT S START=Y .S Y=NOW D DD^%DT S NOW=Y ; ; Message for server S ^TMP("BCH2INIS",$J,1,0)="PACKAGE INSTALL" S ^TMP("BCH2INIS",$J,2,0)="SITE: "_SITE S ^TMP("BCH2INIS",$J,3,0)="PACKAGE: "_PACKAGE S ^TMP("BCH2INIS",$J,4,0)="VERSION: "_VER S ^TMP("BCH2INIS",$J,5,0)="Start time: "_START S ^TMP("BCH2INIS",$J,6,0)="Completion time: "_NOW S ^TMP("BCH2INIS",$J,7,0)="Run time: "_RUN S ^TMP("BCH2INIS",$J,8,0)="DATE: "_DATE ; ; Data is sent to server on FORUM - S.A5CSTS S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""BCH2INIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION" D ^XMD K ^TMP("BCH2INIS",$J) Q BCH2INIT BCH2INIT ; ; 26-JUN-1997 ;;1.0;IHS RPMS CHR SYSTEM;**3**;JUN 26, 1997 ; K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT S DIOVRD=1,U="^",DIFQ=0,DIFROM="1.0" W !,"This version (#1.0) of 'BCH2INIT' was created on 26-JUN-1997" W !?9,"(at TUCSON DEVELOPMENT 486 SCO-BOX, by VA FileMan V.21.0)",! I $D(^DD("VERSION")),^("VERSION")'<21 G GO ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q GO ; EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM S DIFQ=0 K DIRUT,DTOUT,DUOUT F DIFRIR=1:1:1 S DIFRRTN="^BCH2INI"_$E("5",DIFRIR) D @DIFRRTN W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:2 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I) S DIFROM="1.0" D PKG:'$D(DIFROM(0)),^BCH2INI1 G Q:'$D(DIFQ) S DIK(0)="AB" F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) K DIFQR D ^BCH2INI2,^BCH2INI3 L S DUZ=DIDUZ W:1 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE" I DIFROM F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN I DIFROM,$D(^%ZTSK) S X="BCH2INIS" X ^%ZOSF("TEST") D:$T PAC^BCH2INIS($T(IXF),.DIFROM) S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." Q R G REP^BCH2INI2 ; 1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 S DIFQ(N)=$P(DIF(I),";",7)'="n" I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 Q Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ; PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC Q ; IXF ;;BCH2-CHR SYSTEM PATCH 3^BCH2;6 BCHABC1 BCHABC1 ; IHS/TUCSON/LAB - CREATE PCC V FILE ENTRIES FROM CHR RECORD ; [ 11/04/98 8:37 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**4,5,6**;OCT 28, 1996 ; ; IHS/TUCSON/DCP - PATCH 4 10/17/97 - change location of a line of ; code in tag POV to avoid UNDEFINED errors. ; ; CMI/TUCSON/LAB - PATCH 5 6/22/98 - change reference to BCHPROB ; to BCHTPROB ; modified V LAB creation ;Create PCC Visit - continued. ;Creates V File entries for V Provider, V POV, V Measurement, ; V Activity Time, V Skin Test, V Lab and Reproductive Factors ;Calls APCDALVR to create entries. If entry fails, a bulletin ; is sent to appropriate users. ; ;IHS/CMI/LAB - 9/17/1998 - - patch 6 changes icd codes to generic for health education and case finding service codes ; ; VFILES ;EP Create v file entries D PROV I $G(BCHQUIT) D VFERROR D POV D MEAS D AT D SKINTEST D LABS D REPRO I $D(BCHQUIT) D VFERROR D KILL D EOJ Q KILL ; K APCDALVR,BCHPAT,BCHLOC,BCHTYPE,BCHCAT,BCHCLN,BCHTPRO,BCHTPS,BCHTPOV,BCHTNQ,BCHTTOP,BCHTLOU,BCHTPRV,BCHTAT,BCHATMP,BCHAFLG,BCHAUTO,BCHANE,AUPNTALK,BCHAPPT Q ; APCDALVR ;call APCDALVR D ^APCDALVR I $D(APCDALVR("APCDAFLG")) S BCHQUIT=APCDALVR("APCDAFLG") D VFERROR Q S BCHV("VFILES",APCDALVR("APCDAVF"),APCDALVR("APCDADFN"))="" Q PROV ; v provider S BCHFILE="V PROVIDER" D KILL S APCDALVR("APCDVSIT")=BCHVSIT S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]" S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) S APCDALVR("APCDTPS")="P" S X=$P(BCHEV("DATA0"),U,3) I '$P($G(^AUTTSITE(1,0)),U,22) S P=$P(BCHEV("DATA0"),U,3),A=$P(^DIC(3,P,0),U,16) D K A,P Q:X="" .I A="" S BCHQUIT=42,X="" Q .I $P(^VA(200,P,0),U)'=$P(^DIC(16,A,0),U) S BCHQUIT=42,X="" Q .S X=A I X="" S BCHQUIT=41 Q I X]"" S APCDALVR("APCDTPRO")="`"_X D APCDALVR Q POV ;create V POVS S BCHFILE="V POV" S (BCHX,BCHGOT)=0 F S BCHX=$O(BCHEV("POV",BCHX)) Q:BCHX'=+BCHX D .S X=$G(BCHEV("POV",BCHX,"SRV")) Q:'$P(X,U,4) ;don't pass non-pcc services .D KILL .;IHS/TUCSON/DCP PATCH 4 - next line in wrong place: moved 6 lines down .;S APCDALVR("APCDTPOV")=BCHEV("POV",BCHX,"ICD9") I APCDALVR("APCDTPOV")="" S BCHQUIT=43 D VFERROR Q .S APCDALVR("APCDVSIT")=BCHVSIT .S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" .S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) .S APCDALVR("APCDOVRR")="" .;S APCDALVR("APCDTNQ")="`"_$P(BCHEV("POV",BCHX),U,6) .;IHS/TUCSON/DCP PATCH 4 - next line moved from old location at POV+5 .S APCDALVR("APCDTPOV")=BCHEV("POV",BCHX,"ICD9") I APCDALVR("APCDTPOV")="" S BCHQUIT=43 D VFERROR Q .I $P($G(BCHEV("POV",BCHX,"SRV")),U,3)="HE" S APCDALVR("APCDTPOV")="V65.49" ;IHS/CMI/LAB - override ICD9 code for Health Education patch 6 09/17/98 .I $P($G(BCHEV("POV",BCHX,"SRV")),U,3)="CF" S APCDALVR("APCDTPOV")="V82.8" ;IHS/CMI/LAB - override ICD9 code for Case Finding/Screening patch 6 09/17/98 .S X=$P(BCHEV("POV",BCHX),U,6) .S X=$S(X:$E($P(^AUTNPOV(X,0),U),1,74),1:$E($P(^BCHTPROB($P(BCHEV("POV",BCHX),U),0),U),1,74)) ;CMI/TUCSON/LAB - changed BCHPROB to BCHTPROB patch 5 6/22/98 .S APCDALVR("APCDTNQ")=X_" - CHR" .D APCDALVR .Q Q LABS ; Q:'$D(BCHEV("DATA13")) ;no labs passed Q:$G(BCHEV("DATA13"))="" ;no labs passed S BCHFILE="V LAB" S BCHMEAS="BLOOD SUGAR;;THROAT CULTURE;;UA;;HCT" ;IHS/TUCSON/LAB - reversed UA and HCT patch 5 F BCHX=1:2:7 I $P(BCHEV("DATA13"),U,BCHX)!($P(BCHEV("DATA13"),U,(BCHX+1))]"") D ;IHS/TUCSON/LAB - modified 8 to 7 patch 5 .D KILL .S APCDALVR("APCDVSIT")=BCHVSIT .S APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]" .S APCDALVR("APCDTLAB")=$P(BCHMEAS,";",BCHX) .S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) .S APCDALVR("APCDTRES")=$P(BCHEV("DATA13"),U,(BCHX+1)) .D APCDALVR .Q K BCHMEAS,BCHX Q REPRO ;reproductive factors Q:$P(^DPT($P(BCHEV("DATA0"),U,4),0),U,2)'="F" I $P($G(BCHEV("DATA0")),U,13)="",$P($G(BCHEV("DATA0")),U,14)="" Q K BCHQUIT S BCHFILE="REPRODUCTIVE FACTORS" I '$D(^AUPNREP($P(BCHEV("DATA0"),U,4))) S X=$P(BCHEV("DATA0"),U,4),DLAYGO=9000017,DIADD=1,DINUM=X,DIC="^AUPNREP(",DIC(0)="L" K DD D FILE^DICN K DIC,DA,DIADD,DLAYGO,X D Q:$D(BCHQUIT) .I Y=-1 S BCHQUIT=44 Q .Q K DR,DIE I $P(BCHEV("DATA0"),U,13)]"" S Y=$P(BCHEV("DATA0"),U,13) D DD^%DT S DR="2///"_Y_";2.1///^S X="_$P(BCHEV("DATA0"),U),DA=$P(BCHEV("DATA0"),U,4),DIE="^AUPNREP(" D ^DIE K DIE,DA,DR,DIV,DIY,DIW I $D(Y) S BCHQUIT=45 Q I $P(BCHEV("DATA0"),U,14)]"" S Y=$P(BCHEV("DATA0"),U,14) S Y=$P(^BCHTFPM(Y,0),U,3) S DR="3///"_Y_";3.1///^S X="_$P($P(BCHEV("DATA0"),U),"."),DA=$P(BCHEV("DATA0"),U,4),DIE="^AUPNREP(" D ^DIE K DIE,DA,DR,DIV,DIY,DIW I $D(Y) S BCHQUIT=45 Q Q MEAS ; Q:'$D(BCHEV("DATA12")) ;no measurements passed Q:$G(BCHEV("DATA12"))="" ;no measurements passed S BCHFILE="V MEASUREMENT" S BCHMEAS="BP;WT;HT;HC;VU;VC;TMP;PU;RS;" F BCHX=1:1:9 I $P(BCHEV("DATA12"),U,BCHX)]"" D .D KILL .S APCDALVR("APCDVSIT")=BCHVSIT .S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]" .S APCDALVR("APCDTTYP")=$P(BCHMEAS,";",BCHX) .S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) .S APCDALVR("APCDTVAL")=$P(BCHEV("DATA12"),"^",BCHX) .D APCDALVR .Q K BCHMEAS,BCHX Q SKINTEST ; Q:$P($G(BCHEV("DATA12")),U,10)="" S BCHFILE="V SKIN TEST" D KILL S APCDALVR("APCDTSK")="PPD" S APCDALVR("APCDVSIT")=BCHVSIT S APCDALVR("APCDATMP")="[APCDALVR 9000010.12 (ADD)]" S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) S APCDALVR("APCDTREA")=$P(BCHEV("DATA12"),U,10) S Y=$P($P(BCHEV("DATA0"),U),".") D DD^%DT S APCDALVR("APCDTDR")=Y D APCDALVR Q AT ;create v activity time record S BCHFILE="V ACTIVITY TIME" D KILL S (BCHX,BCHT)=0 F S BCHX=$O(BCHEV("POV",BCHX)) Q:BCHX'=+BCHX S BCHT=BCHT+$P(BCHEV("POV",BCHX),U,5) S APCDALVR("APCDTACT")=BCHT S APCDALVR("APCDVSIT")=BCHVSIT S APCDALVR("APCDATMP")="[APCDALVR 9000010.19 (ADD)]" S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) S APCDALVR("APCDTTM")=+$P(BCHEV("DATA0"),U,11) D APCDALVR Q EOJ ; D KILL K BCHDATK,BCHPAT,BCHX,BCHACTL,BCHLOC Q VFERROR ;EP S BCHIEN=BCHEV("CHR IEN") S BCHERR="VE"_BCHQUIT,BCHERR=$P($T(@BCHERR),";;",2) D LBULL^BCHALD K BCHQUIT,BCHERR Q ; VE1 ;;incorrect template specification VE2 ;;invalid values being passed to V file. VE3 ;;invalid visit parameters (date, location etc.) VE41 ;;No PROVIDER ENTRY PASSED from CHR SYSTEM. VE42 ;;Could NOT convert 200 Pointer to 6 pointer. VE43 ;;Could not find ICD9 code in ICD DIagnosis file. VE44 ;;Could not create entry in Reproductive Factors file VE45 ;;Error updating LMP or FP Method in Reproductive Factors file BCHABCH BCHABCH ; IHS/TUCSON/LAB - CHR TO PCC LINK ROUTINE ; [ 06/09/99 12:36 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**3**;OCT 28, 1996 ; ;IHS/TUCSON/LAB - PATCH 3 6/26/97 - DON'T PASS VISITS WITH NO SERVICE TIME ;chr to pcc link ;chr system will pass array BCHEV ;BCHEV("TYPE")=A,E OR D ;Called from BCHALD routine to check BCHEV array and then ;create, edit or delete a PCC Visit as appropriate. ; EP ;EP - call from BCHALD DRIVER W:'$D(ZTQUEUED) !!,"Updating PCC .. hold on.." K BCHQUIT,APCDALVR I '$D(BCHEV) Q ;no array defined I "AED"'[$G(BCHEV("TYPE")) Q ;no appropriate type D @BCHEV("TYPE") D EOJ Q ; CHECK ;EP I '$D(BCHEV("DATA0")) S BCHQUIT=20 Q ;no data array I '$P(BCHEV("DATA0"),U,4) S BCHQUIT=21 Q ;no patient I '$P(BCHEV("DATA0"),U,27) S BCHQUIT=1 Q ;ihs/tucson/lab - added this line, patch 3 if no service time don't pass visit S (BCHX,BCHGOT)=0 F S BCHX=$O(BCHEV("POV",BCHX)) Q:BCHX'=+BCHX D .S X=$G(BCHEV("POV",BCHX,"SRV")) Q:'$P(X,U,4) ;don't pass non-pcc services .S BCHGOT=1 .Q S:'BCHGOT BCHQUIT=1 Q A ;EP - added a record K APCDALVR,BCHQUIT D CHECK I $G(BCHQUIT) D EOJ Q ;quit if not a visit pcc wants D VISIT ;set up and create visit I $G(BCHQUIT) D EOJ Q D ^APCDALV ;create visit I $D(APCDALVR("APCDAFLG")) S BCHQUIT=APCDALVR("APCDAFLG") D VSERROR Q S BCHVSIT=APCDALVR("APCDVSIT") D VFILES^BCHABC1 ;call protocol signifying a complete visit added to pcc files S BCHV("9000010")=BCHVSIT D COMPLETE^BCHALD D EOJ Q E ;edited a chr record D E^BCHABC2 Q D ; D D^BCHABC2 Q VISIT ;EP S APCDALVR("APCDAUTO")="" S:BCHEV("TYPE")="A" APCDALVR("APCDADD")="" S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4) S (APCDALVR("APCDDATE"),BCHDATK)=$P(BCHEV("DATA0"),U) ;date of visit .01 D GETLOC I $G(BCHQUIT) D VSERROR Q D GETTYPE ; get type of visit I $G(BCHQUIT) D VSERROR Q SERVCAT ;get service category - if radio/telephone act loc use T ;otherwise use A ;I can't distinguish hospital from clinic S APCDALVR("APCDCAT")=$S(BCHACTL="RT":"T",1:"A") CLINIC ;get clinic - if act. loc is home use 11 otherwise 01 S APCDALVR("APCDCLN")=$S(BCHACTL="HM":$O(^DIC(40.7,"C",11,"")),1:$O(^DIC(40.7,"C","25",""))) S APCDALVR("APCDAPPT")="U" Q ; GETLOC ;get location of encounter I '$D(BCHEV("ACTLOC")) S BCHQUIT=21 Q ;can't tell activity location S BCHACTL=$P(BCHEV("ACTLOC"),U,5) S BCHLOC=$P(BCHEV("DATA0"),U,5) I BCHLOC S APCDALVR("APCDLOC")=BCHLOC Q ;quit if have a hosp/clinic pointer I BCHACTL="HC" S BCHQUIT=24 Q ;home visit I BCHACTL="HM" S BCHLOC=$P(BCHEV("SITE"),U,5) I BCHLOC="" S BCHQUIT=22 Q I BCHACTL="CH" S BCHLOC=$P(BCHEV("SITE"),U,6) I BCHLOC="" S BCHQUIT=27 Q I 'BCHLOC S BCHLOC=$P(BCHEV("SITE"),U,9) I BCHLOC="" S BCHQUIT=23 Q S APCDALVR("APCDLOC")=BCHLOC Q GETTYPE ;get type of visit S BCHLOC=$P(^AUTTLOC(APCDALVR("APCDLOC"),0),U,10) I $E(BCHLOC,5,6)>49 S APCDALVR("APCDTYPE")="T" Q ;if not a clinic, set to tribal and quit S APCDALVR("APCDTYPE")=$P(BCHEV("SITE"),U,4) Q:APCDALVR("APCDTYPE")'="" S X=$P(^AUTTLOC(APCDALVR("APCDLOC"),0),U,25) I X]"" S APCDALVR("APCDTYPE")=$S(X=1:"I",X=2:"6",X=3:"C",X=6:"T",1:"O") Q ;if loc updated use it S X=$P($G(^APCCCTRL(DUZ(2),0)),U,4) I X]"" S APCDALVR("APCDTYPE")=X Q ;use pcc master control if all else fails S APCDALVR("APCDTYPE")="T" ;default to T if can't determine Q ; EOJ ; K BCHLINK,BCHFILE,BCHERR,BCHQUIT,APCDALVR,BCHTYPE,BCHLOC,BCHDATK,BCHACTL,BCHIEN,BCHX,BCHGOT,BCHVSIT K BCHEV Q VSERROR ;EP S BCHFILE="VISIT" S BCHIEN=BCHEV("CHR IEN") S BCHERR="VE"_BCHQUIT,BCHERR=$P($T(@BCHERR),";;",2) D LBULL^BCHALD Q ; VE2 ;;inability to create visit VE3 ;;invalid visit parameters (date, location etc.) VE21 ;;No activity location passed. No Location determined. VE22 ;;No IHS Location for HOME in CHR SITE PARAMETER File. VE23 ;;No IHS Location for OTHER in CHR SITE PARAMETER File. VE24 ;;No Location of Encounter when Activity location is Hospital/Clinic. VE27 ;;No Location of Encounter for OFFICE in CHR SITE PARAMETER file. VE28 ;;Error attempting to modify visit BCHDCOMM BCHDCOMM ; IHS/TUCSON/LAB - COMMUNITY DOWNLOAD ROUTINE ; [ 06/03/99 8:56 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ; ;Generates COMMUNITY file for uploading onto the remote ;computer systems. ; EP ; W:$D(IOF) @IOF W !!,"This utility routine is used to download, by Area, all communities in the",!,"COMMUNITY file to the remote computer." W !!,"You will be asked to enter your Area. A unix file will be created",!,"called communit.imp. It must be then put in the C:\CHR directory on the ",!,"remote and uploaded into that machine.",!! ; S C=0 K ^XTMP("BCH COMMUNITIES",$J) S ^XTMP("BCH COMMUNITIES",0)=$$FMADD^XLFDT(DT,14)_U_DT_"CHR DOWNLOAD" D AREA Q:'BCHQ D COMM D WRITEF D XIT Q ; ;--------------------------------------------- AREA ;select desired area S BCHQ=1 S DIC="^AUTTAREA(",DIC(0)="AEMQ" D ^DIC I Y=-1 W:'$D(^XTMP("BCH COMMUNITIES")) !!,"NO AREA SELECTED." S BCHQ=0 Q S BCHAREA=+Y Q COMM ;get communities and set in ^XTMP S BCHIEN=0 F S BCHIEN=$O(^AUTTCOM(BCHIEN)) Q:BCHIEN'=+BCHIEN D . Q:$P(^AUTTCOM(BCHIEN,0),U,6)'=BCHAREA . S C=C+1 . S ^XTMP("BCH COMMUNITIES",$J,C)=""""_$P(^AUTTCOM(BCHIEN,0),U,8)_""""_","_""""_$P(^AUTTCOM(BCHIEN,0),U)_"""" . Q Q ; WRITEF ;EP - write out flat file I '$D(^XTMP("BCH COMMUNITIES")) W !!,"NO COMMUNITIES SELECTED." G XIT W !,"You have selected ",C," communites to be downloaded. Here they are: " H 2 S X=0 F S X=$O(^XTMP("BCH COMMUNITIES",$J,X)) Q:X'=+X W !,^XTMP("BCH COMMUNITIES",$J,X) W ! S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" K DA D ^DIR K DIR I $D(DIRUT)!('Y) W !!,"BYE",! G XIT S XBGL="TMP("_"""BCH COMMUNITIES"""_","_$J_"," S XBMED="F",XBFN="communit.imp",XBTLE="SAVE OF COMMUNITIES" S XBF=0,XBQ="N",XBFLT=1,XBE=$J D ^XBGSAVE Q XIT ; K ^XTMP("BCH COMMUNITIES",$J) K BCHQ,C,X Q BCHDHS BCHDHS ; IHS/TUCSON/LAB - CHR HEALTH SUMMARY COMPONENT ; [ 06/03/97 12:38 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed the display of referral data ;Called from health summary component called CHR. ;Extracts and writes information on the health summary from the ;CHR data file. ; CHR ;EP called from health summary X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK OUTPT ; ********** CHR PROBLEM CODES AND DESIGNATED PROVIDER ; I '$D(^BCHR("AE",APCHSPAT)) X APCHSCKP Q:$D(APCHSQIT) W !,"No CHR Records on File.",! Q ; S BCHSPVD=0 F BCHSIVD=0:0 S BCHSIVD=$O(^BCHR("AE",APCHSPAT,BCHSIVD)) Q:BCHSIVD=""!(BCHSIVD>APCHSDLM) D ONEDATE Q:$D(APCHSQIT) S:(BCHSDAT'=BCHSPVD)&BCHSDTU APCHSNDM=APCHSNDM-BCHSDTU,BCHSPVD=BCHSDAT Q:APCHSNDM=0 OUTPTX K BCHSIVD,BCHSDTU,BCHSVDF,BCHSFAC,BCHSPFN,BCHSMTX,BCHSPVD,BCHSOVT,BCHSNDT,BCHSCLI,BCHSPDN,BCHSICD,BCHSICL,BCHSDAT,BCHSN,BCHSQ,BCHSR,BCHSX,BCHS,BCHACTL,BCHSNRQ K BCHSNFL,BCHSNSH,BCHSNAB,BCHSVSC,BCHSFAC,Y,D0 Q ONEDATE S Y=-BCHSIVD\1+9999999 X APCHSCVD S BCHSDAT=Y S BCHSPFN="",BCHSDTU=0,BCHSNDT=(BCHSDAT'=BCHSPVD) S BCHSVDF="" F BCHSQ=0:0 S BCHSVDF=$O(^BCHR("AE",APCHSPAT,BCHSIVD,BCHSVDF)) Q:BCHSVDF="" S BCHSN=^BCHR(BCHSVDF,0) D GETSITE,DSPVIS Q:$D(APCHSQIT) Q ; GETSITE ; S BCHACTL=$P(BCHSN,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,10) S BCHSFAC=$P(BCHSN,U,5) I BCHSFAC]"" S BCHSFAC=$P(^AUTTLOC(BCHSFAC,0),U,2) I BCHSFAC="" S BCHSFAC=BCHACTL Q DSPVIS ; S BCHSDTU=1 I $O(^BCHRPROB("AD",BCHSVDF,""))="" D NOPOV Q S BCHSPDN="" F BCHSQ=0:0 S BCHSPDN=$O(^BCHRPROB("AD",BCHSVDF,BCHSPDN)) Q:'BCHSPDN S BCHSR=^BCHRPROB(BCHSPDN,0) D HASPOV ;display measurements K X N Z S Y=$G(^BCHR(BCHSVDF,12)) I Y]"" S Z="BP^WT^HT^HC^VU^VC^TMP^PU^RESP^PPD",C=0 F I=1:1:10 I $P(Y,U,I)]"" S C=C+1,X(C)=$P(Z,U,I)_"^"_$P(Y,U,I) I $D(X) S I=0,J=25,C=0 F S I=$O(X(I)) Q:I'=+I S C=C+1 W:C=1 ! W ?J,$P(X(I),U)," ",$P(X(I),U,2) S J=J+18 S:C=3 C=0,J=25 I $P(BCHSN,U,9)]"" W !?25,"Evaluation: ",$$EXTSET^XBFUNC(90002,.09,$P(BCHSN,U,9)),! ;IHS/TUCSON/LAB - patch 2 ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed referral display I $P(BCHSN,U,7)="",$P(BCHSN,U,8)="" W ! Q W ?25,"Referred BY: ",$E($S($P(BCHSN,U,7)]"":$P(^BCHTREF($P(BCHSN,U,7),0),U),1:""),1,11) W ?50,"Referred TO: ",$E($S($P(BCHSN,U,8):$P(^BCHTREF($P(BCHSN,U,8),0),U),1:""),1,12),! Q ; NOPOV ; S APCHSTXT="",(BCHSICD,APCHSNRQ)="" G COMMON ; HASPOV ; S BCHSICD=$E($P(^BCHTPROB($P(BCHSR,U),0),U),1,20)_" ("_$P(^BCHTPROB($P(BCHSR,U),0),U,2)_") - "_$E($P(^BCHTSERV($P(BCHSR,U,4),0),U),1,20)_" AT: "_$P(BCHSR,U,5)_$S($P(BCHSR,U,7):" - S/R",1:"") S BCHSNRQ=$P(BCHSR,U,6),BCHSNRQ=$P(^AUTNPOV(BCHSNRQ,0),U),APCHSTXT="" D COMMON Q COMMON ; X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG BCHSNDT=1 I BCHSNDT W BCHSDAT S BCHSPFN="",BCHSNDT=0 W ?9,BCHSFAC,?20,$$PPINI^BCHUTIL(BCHSVDF) S APCHSICL=25,APCHSNRQ=BCHSICD D PRTTXT^APCHSUTL S APCHSTXT="",APCHSICL=25,APCHSNRQ=BCHSNRQ D PRTTXT^APCHSUTL Q BCHDHS1 BCHDHS1 ; IHS/TUCSON/LAB - CHR HEALTH SUMMARY COMPONENT PART 2 ; [ 06/22/98 9:31 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**5**;OCT 28, 1996 ; ;CMI/TUCSON/LAB - patch 5 6/22/98 - modified reference to BCHPROB to BCHTPROB ; ;Continuation of BCHDHS ; PROB ;EP X APCHSCKP Q:$D(APCHSQIT) S X="<<< CHR ACTIVE PROBLEMS >>>",BCHS="",$P(BCHS," ",IOM-1-$L(X)/2)="" W !,BCHS,X,BCHS,! S BCHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)" S BCHTTAT="A" D COMMON X APCHSCKP Q:$D(APCHSQIT) S X="<<< CHR INACTIVE PROBLEMS >>> ",BCHS="",$P(BCHS," ",IOM-1-$L(X)/2)="" W !,BCHS,X,BCHS,! S BCHTTAT="I" D COMMON K BCHTCVD,BCHTQ,Y,BCHHS,BCHPTP D PROBX Q COMMON ; K BCHTDFT S BCHTNDF=0 S BCHTPRB="" F BCHTQ=0:0 S BCHTPRB=$O(^BCHPPROB("AA",APCHSPAT,BCHTPRB)) Q:BCHTPRB="" S BCHTDFN=$O(^(BCHTPRB,"")) S:$P(^BCHPPROB(BCHTDFN,0),U,12)=BCHTTAT BCHTNDF=BCHTNDF+1,BCHTDFT(BCHTPRB)=BCHTDFN I BCHTNDF=0 X APCHSCKP Q:$D(APCHSQIT) S X=" ",BCHS="",$P(BCHS," ",IOM-1-$L(X)/2)="" W BCHS,X,BCHS,! ;X APCHSCKP Q:$D(APCHSQIT) W !!,"***** ",$S(BCHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND TREATMENT PLANS/NOTES ***** ",!! S BCHTFPP="" F BCHTQ=0:0 S BCHTFPP=$O(BCHTDFT(BCHTFPP)) Q:BCHTFPP="" S BCHTDFN=BCHTDFT(BCHTFPP) D PROBDSP PROBX K BCHTDFT,BCHTNDF,BCHTFPP,BCHTPLN,BCHTPBN,BCHTDTM,BCHTDTN,BCHTPRB,BCHTTAT,BCHTNFP,BCHTNRQ,BCHTPNM,BCHTDFN,BCHTFCN,BCHTICD,BCHTICL,BCHTILN,BCHTN,BCHTTPT K BCHTNFL,BCHTNSH,BCHTNAB,BCHTVSC,BCHTITE Q PROBSCH ; Q PROBDSP ; S BCHTN=^BCHPPROB(BCHTDFN,0) S BCHTNRQ=$P(BCHTN,U,5) D GETNARR I 1 E S BCHTNRQ="" S BCHTDOO=$P(BCHTN,U,13) I BCHTDOO]"" S Y=BCHTDOO X BCHTCVD S BCHTDOO=Y S BCHTPNM=+$P(BCHTN,U,7) S Y=$P(BCHTN,U,3) X BCHTCVD S BCHTDTM=Y S Y=$P(BCHTN,U,8) X BCHTCVD S BCHTDTN=Y ;S BCHTPLN=BCHTPNM_$E(" ",1,8-$L(BCHTPNM))_BCHTDTM X APCHSCKP Q:$D(APCHSQIT) W !,BCHTPNM,?4,BCHTDTM S BCHTICL=14,BCHTILN=61 D PRTICD D NOTEDSP Q NOTEDSP ; DISPLAY NOTES UNDER PROBLEM Q:'$D(^BCHPTP("AE",BCHTDFN)) ;no notes S BCHTNDF=0 F BCHTQ=0:0 S BCHTNDF=$O(^BCHPTP("AE",BCHTDFN,BCHTNDF)) Q:'BCHTNDF D DSPN Q DSPN ; DISPLAY SINGLE NOTE S X=$O(^BCHPTP("AE",BCHTDFN,BCHTNDF,"")) Q:X="" S BCHTN=^BCHPTP(X,0) S BCHTDOI=$P(BCHTN,U,5) I BCHTDOI]"" S Y=BCHTDOI X BCHTCVD S BCHTDOI=Y S BCHTTPT=$P(BCHTN,U,7) S BCHTTPT=$S(BCHTTPT=1:"STP",BCHTTPT=2:"LTP",1:" ") S BCHHS("AUTHOR")=$P(BCHTN,U,6) S BCHHS("AUTHOR")=$S(BCHHS("AUTHOR")]"":$$PROVINI^XBFUNC1($P(BCHTN,U,6)),1:"???") X APCHSCKP Q:$D(APCHSQIT) W ?1,BCHTPNM_"-"_$P(BCHTN,U),?7,BCHTTPT,?11,BCHTDOI,?20,BCHHS("AUTHOR") S APCHSNRQ=$P(BCHTN,U,4),APCHSICL=24,APCHSTXT="" D PRTTXT^APCHSUTL K BCHTDOI Q ; PRTICD ; S:BCHTNRQ="" BCHTNRQ="" S BCHTICD="" S BCHTTXT=BCHTICD D PRTTXT Q ; PRTTXT ; GENERALIZED TEXT PRINTER S BCHTDLT=1,BCHTILN=80-BCHTICL-1 ;S BCHTNRQ="["_$E($P(^BCHTPROB($P(BCHTN,U),0),U,2),1,25)_"] "_BCHTNRQ S BCHTNRQ=BCHTNRQ_" ("_$P(^BCHTPROB($P(BCHTN,U),0),U)_")" ;CMI/TUCSON/LAB - PATCH 5 changed ^BCHPROB to ^BCHTPROB 6/22/98 I BCHTDOO]"" S BCHTNRQ=BCHTNRQ_" (ONSET: "_BCHTDOO_")" F BCHTQ=0:0 S:BCHTNRQ]""&(($L(BCHTNRQ)+$L(BCHTTXT)+2)<255) BCHTTXT=$S(BCHTTXT]"":BCHTTXT_"; ",1:"")_BCHTNRQ,BCHTNRQ="" Q:BCHTTXT="" D PRTTXT2 K BCHTILN,BCHTDLT,BCHTF,BCHTC,BCHTTXT,BCHTDOO Q PRTTXT2 D GETFRAG W ?BCHTICL W BCHTF,! S BCHTICL=BCHTICL+BCHTDLT,BCHTILN=BCHTILN-BCHTDLT,BCHTDLT=0 Q GETFRAG I $L(BCHTTXT)BCHED) D D1 Q ; XIT ; S BCHET=$H D EOJ Q EOJ ; Q D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("AEX",BCHODAT,BCHR)) Q:BCHR'=+BCHR S BCHREC=^BCHR(BCHR,0) D PROC Q PROC ; S BCHREC=^BCHR(BCHR,0) K BCHE,BCHTX S (BCHCPOV,BCHPOVD)=0 F S BCHPOVD=$O(^BCHRPROB("AD",BCHR,BCHPOVD)) Q:BCHPOVD'=+BCHPOVD D .S BCHCPOV=BCHCPOV+1 .D RECORD^BCHEXD2 I '$D(^BCHRPROB("AD",BCHR)) S BCHE="E021" ;IHS/CMI/LAB Q:BCHE="" S BCH("ERROR COUNT")=BCH("ERROR COUNT")+1 S BCHE("ERR DFN")=$O(^BCHERR("B",BCHE,"")) I BCHE("ERR DFN")="" S BCHE("MSG")=BCHE_"-ERROR INFORMATION NOT IN ERROR FILE" G ERR S BCHE("MSG")=BCHE_"-"_$P(^BCHERR(BCHE("ERR DFN"),0),U,2) S:$L(BCHE("MSG"))=5 BCHE("MSG")=BCHE("MSG")_"- ERROR INFORMATION NOT IN ERROR FILE" S BCHE("MSG")=$E(BCHE("MSG"),1,45) ERR S ^XTMP("BCHEXC",BCHJOB,BCHBT,"ERRORS",BCHR)=BCHE("MSG") Q ; BCHEXCP BCHEXCP ; IHS/TUCSON/LAB - PRNT RECORD REVIEW ; [ 06/05/99 9:03 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**3,7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ;IHS/TUCSON/LAB - PATCH 3 CHANGED FILE NUMBERS AND FIELD NUMBER ON CHR DISPLAY ;Print export record check report. ; START ; S BCH80E="===============================================================================" S BCH80D="-------------------------------------------------------------------------------" S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S BCHPG=0 D HEAD I '$D(^XTMP("BCHEXC",BCHJOB,BCHBT)) W !,"No errors to report",! G DONE S BCHR=0 K BCHQUIT F S BCHR=$O(^XTMP("BCHEXC",BCHJOB,BCHBT,"ERRORS",BCHR)) Q:BCHR=""!($D(BCHQUIT)) D PROC G:$D(BCHQUIT) DONE I $Y>(IOSL-6) D HEAD G:$D(BCHQUIT) DONE DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHEXC",BCHJOB,BCHBT) Q PROC ; I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) S Y=$P(BCHREC,U) D DD^%DT S BCHDATE=Y S BCHNAME=$P(^BCHR(BCHR,0),U,8) I BCHNAME]"" S BCHNAME=$E($P(^DPT(BCHNAME,0),U),1,20) S BCHHRCN="" I $P(^BCHR(BCHR,0),U,8) S BCHHRCN=$S($D(^AUPNPAT($P(^BCHR(BCHR,0),U,8),41,DUZ(2),0)):$P(^(0),U,2),1:"") S BCHPROG=$P(^BCHR(BCHR,0),U,2) K ^UTILITY("DIQ1",$J) K DIQ,DIC,DA,DR S DIC="^BCHR(",DR=".03",DA=BCHR,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ S BCHCAT=$E(^UTILITY("DIQ1",$J,90002,BCHR,.03,"E"),1,14) ;ihs/tucson/lab - patch 3 changed file # K ^UTILITY("DIQ1",$J) K DIQ,DIC,DA,DR S DIC="^BCHR(",DR=".06",DA=BCHR,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ S BCHACT=$E(^UTILITY("DIQ1",$J,90002,BCHR,.06,"E"),1,7) ;IHS/TUCSON/LAB - changed file number patch 3 W !!,BCHDATE,?22,BCHNAME,?43,BCHHRCN,?52,BCHPROG,?56,BCHCAT,?74,BCHACT,!,^XTMP("BCHEXC",BCHJOB,BCHBT,"ERRORS",BCHR) Q WPOV ; I $Y>(IOSL-6),BCH2>1 D HEAD Q:$D(BCHQUIT) Q:$P(BCHX,U)="" Q:$P(BCHX,U,4)="" W:BCH2>1 ! W ?41,$P(^ICD9($P(BCHX,U),0),U),?49,$E($P(^AUTNPOV($P(BCHX,U,4),0),U),1,20) Q CHKDISC ; Q:'$D(^VA(200,BCHAP)) S BCHDISC=$$PPCLSC^BCHUTIL(BCHRPROC) S BCHINI=$$PPINI^BCHUTIL(BCHRPROC) Q HEAD ;ENTRY POINT I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; W:$D(IOF) @IOF S BCHPG=BCHPG+1 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BCHPG,! S BCHLENG=26 W ?((80-BCHLENG)/2),"CHR EXPORT RECORD REVIEW",! W ?15,"Record Posting Dates: ",BCHBDD," and ",BCHEDD,! W !!,"RECORD DATE",?22,"PATIENT",?43,"HRN",?51,"PGM",?56,"CHR",?72,"ACT TYPE" ;IHS/TUCSON/LAB - 6/27/97 - TYPE to CHR W !,BCH80D Q BCHEXD BCHEXD ; IHS/TUCSON/LAB - MAIN DRIVER FOR CHR EXPORT TX GEN ; [ 06/03/99 6:46 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB ;added $J to ^TMP ; ;Main driver routine for the generation of transactions to be ;exported to the CHRIS II System. ; START ; I $D(ZTQUEUED) S BCHO("SCHEDULED")="" S BCHO("RUN")="NEW" ; Let BCHEXDI know this is a new run. D ^BCHEXDI ; Do initialization I $D(BCHO("QUEUE")) D EOJ W !!,"Okay, your request is queued! Bye",! Q I BCH("QFLG")=99 D EOJ W !!,"Bye",!! Q I BCH("QFLG") D ABORT Q DRIVER ;called from TSKMN+2 S BCH("BT")=$H D NOW^%DTC S BCH("RUN START")=%,BCH("MAIN TX DATE")=$P(%,".") K %,%H,%I S DIE="^BCHXLOG(",DA=BCH("RUN LOG"),DR=".15///R"_";.03////"_BCH("RUN START") D CALLDIE^BCHUTIL I $D(Y) D ABORT Q S BCHCNT=$S('$D(ZTQUEUED):"X BCHCNT1 X BCHCNT2",1:"S BCHCNTR=BCHCNTR+1"),BCHCNT1="F BCHCNTL=1:1:$L(BCHCNTR)+1 W @BCHBS",BCHCNT2="S BCHCNTR=BCHCNTR+1 W BCHCNTR,"")""" D PROCESS ; Generate trasactions I BCH("QFLG") D ABORT Q D ^BCHEXLOG ; Update Log I BCH("QFLG") D ABORT Q D PURGE ; Purge AEX xref entries D RUNTIME^BCHEXEOJ ; Show run time D TAPE ; Write transactions to tape I BCH("QFLG") D ABORT Q D:'$D(ZTQUEUED) CHKLOG ; See if Log needs cleaning I '$D(ZTQUEUED) W !! S DIR(0)="E",DIR("A")="DONE -- Press RETURN to Continue" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 D EOJ Q ; PROCESS ; ;build header record S BCH("COUNT")=BCH("COUNT")+1,^BCHRDATA(BCH("COUNT"))="CR^" W:'$D(ZTQUEUED) !,"Generating transactions. Counting records. (1)" S BCHCNTR=0,BCH("CONTROL DATE")=BCH("RUN BEGIN")-1,BCH("POSTING DATE")=" " S BCHRTYPE="U" F S BCH("CONTROL DATE")=$O(^BCHR("AEX",BCH("CONTROL DATE"))) Q:BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END")) D PROCESS2 Q:BCH("QFLG") S BCHRTYPE="D" D DELETES ;gather up and send deletes Q PROCESS2 ; S BCHR="" F S BCHR=$O(^BCHR("AEX",BCH("CONTROL DATE"),BCHR)) Q:BCHR="" D PROCESS3 Q:BCH("QFLG") Q PROCESS3 ; K BCHE,BCHCPOV Q:$D(^BCHXLOG(BCH("RUN LOG"),21,BCHR)) S BCHV("TX GENERATED")=0,^TMP("BCHDR",$J,BCH("CONTROL DATE"),BCHR)="",^TMP("BCHDR",$J,"MAIN TX",BCHR)="" S BCH("VISIT COUNT")=BCH("VISIT COUNT")+1 X BCHCNT I '$D(^BCHRPROB("AD",BCHR)) S BCHE="E021" D CNTBUILD Q S BCHREC=^BCHR(BCHR,0) K BCHE,BCHTX S (BCHCPOV,BCHPOVD)=0 F S BCHPOVD=$O(^BCHRPROB("AD",BCHR,BCHPOVD)) Q:BCHPOVD'=+BCHPOVD D .S BCHCPOV=BCHCPOV+1 .D RECORD^BCHEXD2 .D CNTBUILD D ^XBFMK S DA=BCH("RUN LOG"),DR="2101///""`"_BCHR_"""",DIE="^BCHXLOG(" S DR(2,90002.912101)=".02////"_BCHV("TX GENERATED")_";.03///"_BCHRTYPE D CALLDIE^BCHUTIL Q ; PURGE ; PURGE 'AEX' XREF FOR CHR RECORDS JUST DONE W:'$D(ZTQUEUED) !,"Deleting cross-reference entries. (1)" S BCHCNTR=0,BCHV("R DATE")="" F S BCHV("R DATE")=$O(^TMP("BCHDR",$J,BCHV("R DATE"))) Q:BCHV("R DATE")'=+BCHV("R DATE") D PURGE2 DEL ;update delete file S BCHV("R DATE")="" F S BCHV("R DATE")=$O(^TMP("BCHDR",$J,"DELETES",BCHV("R DATE"))) Q:BCHV("R DATE")'=+BCHV("R DATE") D .S BCHR=0 F S BCHR=$O(^TMP("BCHDR",$J,"DELETES",BCHV("R DATE"),BCHR)) Q:BCHR'=+BCHR D ..S DIE="^BCHEXDEL(",DA=BCHR,DR=".06////"_BCH("MAIN TX DATE") D CALLDIE^BCHUTIL K ^TMP("BCHDR") Q PURGE2 ; S BCHR="" F S BCHR=$O(^TMP("BCHDR",$J,BCHV("R DATE"),BCHR)) Q:BCHR="" D RESET Q ; RESET ; kill CHR xref and set flag if tx 23 or 24 generated K ^BCHR("AEX",BCHV("R DATE"),BCHR) I ^TMP("BCHDR",$J,"MAIN TX",BCHR)]"" S DIE="^BCHR(",DA=BCHR,DR=".19///"_^TMP("BCHDR",$J,"MAIN TX",BCHR) D CALLDIE^BCHUTIL X BCHCNT Q ; ; CNTBUILD ;EP count and build tx I BCHE]"" S BCH("ERROR COUNT")=BCH("ERROR COUNT")+1 D ^BCHEXERR Q S BCH("COUNT")=BCH("COUNT")+1 S BCH(BCHRTYPE)=BCH(BCHRTYPE)+1 S BCHV("TX GENERATED")=1,^TMP("BCH"_$S(BCHO("RUN")="NEW":"DR",BCHO("RUN")="REDO":"REDO",1:"DR"),$J,"MAIN TX",BCHR)=BCH("MAIN TX DATE") S ^BCHRDATA(BCH("COUNT"))="CR^"_BCHTX Q TAPE ; COPY TRANSACTIONS TO TAPE D TAPE^BCHEXTAP Q ; CHKLOG ; CHECK LOG FILE S BCH("X")=0 F BCH("I")=BCH("RUN LOG"):-1:1 Q:'$D(^BCHXLOG(BCH("I"))) I $O(^BCHXLOG(BCH("I"),21,0)) S BCH("X")=BCH("X")+1 I BCH("X")>12 W !,"-->There are more than twelve generations of CHR RECORDs stored in the LOG file.",!,"-->Time to do a purge." Q ; ABORT ; ABNORMAL TERMINATION I $D(BCH("RUN LOG")) S BCH("QFLG1")=$O(^BCHDTER("B",BCH("QFLG"),"")),DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".15///F;.16////"_BCH("QFLG1") I $D(ZTQUEUED) D ERRBULL^BCHEXDI3,EOJ Q W !!,"Abnormal termination!! QFLG=",BCH("QFLG") S DIR(0)="E",DIR("A")="DONE -- Press RETURN to Continue" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 D EOJ Q ; DELETES ; D DELETES^BCHEXD2 Q EOJ ; EOJ D ^BCHEXEOJ Q BCHEXD2 BCHEXD2 ; IHS/TUCSON/LAB -PROCESS RECORD ; [ 06/03/99 6:41 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - added $J to ^TMP ; ;Create export record. 68 characters in length. ; RECORD ;EP S (BCHE,BCHTX)="" PROV ;get providers (1-4) I $P(BCHREC,U,3)="" S BCHE="E022" Q S BCHAFF=$$PPAFFL^BCHUTIL(BCHR,"I") I BCHAFF=""!(BCHAFF["?") S BCHE="E023" Q S BCHDISC=$$PPCLSC^BCHUTIL(BCHR) I BCHDISC=""!(BCHDISC["?") S BCHE="E024" Q S BCHINI=$$PPINI^BCHUTIL(BCHR) I BCHINI["?" S BCHE="E025" Q PROV1 S X=BCHAFF_BCHDISC_BCHINI S X=$$LBLK(X,6) D TX PROG ; S X=$P(BCHREC,U,2) I X]"" S X=$P(^BCHTPROG(X,0),U,5) I X="" S X="-1" S X=$$LBLK(X,7) D TX DATE ; S X=$P($P(BCHREC,U),".") D TX FORM ; S X=$P(BCHREC,U,25),X=$$LZERO(X,3) D TX ARN S X=BCHCPOV,X=$$LZERO(X,2) D TX RH S X=$P(BCHREC,U,26) S:X="" X="-" D TX S X=" " D TX SC ; S P=$P(^BCHRPROB(BCHPOVD,0),U,4),X=$S(P]"":$P(^BCHTSERV(P,0),U,3),1:" -") S:X="" X=" -" D TX S X=" " D TX POV ; S X=$P(^BCHRPROB(BCHPOVD,0),U),X=$P(^BCHTPROB(X,0),U,2) S:X="" X="-1" S:X="-" X=" -" D TX S X=" " D TX ACTL ; S X=$P(BCHREC,U,6),X=$S(X]"":$P(^BCHTACTL(X,0),U,5),1:" -") S:X="-" X=" -" S:X="" X=" -" S:X="--" X=" -" D TX NS ; S X=$P(BCHREC,U,12) S:'X X=0 S X=$$LZERO(X,4) D TX ST ; S X=$P(^BCHRPROB(BCHPOVD,0),U,5) S:'X X=1 S X=$$LZERO(X,4) D TX TT ; I BCHCPOV=1 S X=$P(BCHREC,U,11) S:'X X=0 S X=$$LZERO(X,4) E S X=" 0" D TX S X=" " D TX AGE ; S X2=$P($G(^BCHR(BCHR,11)),U,2) I X2]"" D I 1 .S X1=$P($P(BCHREC,U),".") D ^%DTC S BCHAGE=X,BCHAGE=$J(BCHAGE/365.25,3,0) S X=$$LZERO(BCHAGE,3) E S X=" ",X=$$LBLK(X,3) D TX S X=" " D TX SEX ; S X=$S($P($G(^BCHR(BCHR,11)),U,3)]"":$P($G(^BCHR(BCHR,11)),U,3),1:" ") S X=$$LBLK(X,2) D TX S X=" " D TX REFF ; S X="" I BCHCPOV=1 S X=$P(BCHREC,U,7) S:X'="" X=$P(^BCHTREF(X,0),U,3) S:X="" X=" " D TX S X=" " D TX REFT ; S X="" I BCHCPOV=1 S X=$P(BCHREC,U,8) S:X'="" X=$P(^BCHTREF(X,0),U,3) S:X="" X=" " D TX S X=" " D TX SUB ; S X=$P(^BCHRPROB(BCHPOVD,0),U,7) S:X="" X=" " D TX S X=" " D TX EVAL ; S X="" I BCHCPOV=1 S X=$P(BCHREC,U,9) S:X="" X=" " D TX S X=" " D TX TYPE ; S X="U" D TX Q TX ;EP S BCHTX=BCHTX_X Q ; LZERO(V,L) ;EP - left zero fill NEW %,I S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V Q V LBLK(V,L) ;EP - left blank fill NEW %,I S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V Q V RBLK(V,L) ;right blank fill NEW %,I S %=$L(V),Z=L-% F I=1:1:Z S V=V_" " Q V DELETES ;EP - called from BCHEXD , send delete txs S BCH("CONTROL DATE")=BCH("RUN BEGIN")-1 F S BCH("CONTROL DATE")=$O(^BCHEXDEL("AEX",BCH("CONTROL DATE"))) Q:BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END")) D DELETES2 Q:BCH("QFLG") Q DELETES2 ; S BCHR="" F S BCHR=$O(^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR)) Q:BCHR="" D DELETES3 Q:BCH("QFLG") Q DELETES3 ; S BCHTX="" S BCHV("TX GENERATED")=0,^TMP("BCHDR",$J,"DELETES",BCH("CONTROL DATE"),BCHR)=BCH("MAIN TX DATE") X BCHCNT S X=$P(^BCHEXDEL(BCHR,0),U),X=$$LBLK(X,6) D TX S X=$P(^BCHEXDEL(BCHR,0),U,2) S X=$$LBLK(X,7) D TX S X=$P(^BCHEXDEL(BCHR,0),U,3) S X=$$LBLK(X,7) D TX S X=$P(^BCHEXDEL(BCHR,0),U,4) S X=$$LZERO(X,3) D TX S $E(BCHTX,68)=BCHRTYPE D CNTBUILD^BCHEXD K ^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR) Q ; BCHEXDI2 BCHEXDI2 ; IHS/TUCSON/LAB - Export initialization ; [ 06/03/97 12:32 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ;IHS/TUCSON/LAB - modified this to not error out if this is the ;first export and old data exists patch 1 06/03/97 ; ; START ; D INFORM^BCHEXDI3 ; Let operator know what is going on. D GETLOG ; Get last log entry and display data. Q:BCH("QFLG") D CHKOLD Q:BCH("QFLG") D CURRUN^BCHEXDI3 ; Compute run dates for current run. Q:BCH("QFLG") D CHKCHR ; Check CHR RECORD xref for date range Q:BCH("QFLG") D CONFIRM ; Get ok from operator. Q:BCH("QFLG") D GENLOG ; Generate new log entry. Q ; CHKOLD ;EP - CHECK FOR DATA LEFT BY OLD RUN I $D(^BCHRDATA) W:'$D(ZTQUEUED) !!,"*** WARNING *** ^BCHRDATA global exists from a previous GEN or REDO!!" S BCH("QFLG")=32 I $D(^TMP("BCHDR")) W:'$D(ZTQUEUED) !!,"*** WARNING *** ^TMP nodes exist from previous GEN!!," S BCH("QFLG")=10 I $D(^TMP("BCHREDO")) W:'$D(ZTQUEUED) !!,"*** WARNING *** ^TMP nodes exist from previous REDO!!" S BCH("QFLG")=11 Q ; ; ; ; GETLOG ;EP GET LAST LOG ENTRY S (X,BCH("LAST LOG"))=$P(^BCHXLOG(0),U,3) F S X=$O(^BCHXLOG(X)) Q:X'=+X S BCH("LAST LOG")=X S X=$S(BCH("LAST LOG")&($D(^BCHXLOG(BCH("LAST LOG")))):BCH("LAST LOG"),1:0) F S X=$O(^BCHXLOG(X)) Q:X'=+X S BCH("LAST LOG")=X Q:'BCH("LAST LOG") D DISPLOG Q:$P(^BCHXLOG(BCH("LAST LOG"),0),U,15)="C" D ERROR Q ERROR ; S BCH("QFLG")=12 S BCH("PREV STATUS")=$P(^BCHXLOG(BCH("LAST LOG"),0),U,15) I BCH("PREV STATUS")="" D EERR Q D @(BCH("PREV STATUS")_"ERR") Q Q EERR ; S BCH("QFLG")=13 ; Q:$D(ZTQUEUED) W $C(7),$C(7),!!,"*****ERROR ENCOUNTERED*****",!,"The last PCC Data Export never successfully completed to end of job!!!",!,"This must be resolved before any other exports can be done.",! Q PERR ; S BCH("QFLG")=14 ; Q:$D(ZTQUEUED) W !!,$C(7),$C(7),"*****ERROR ENCOUNTERED*****",!,"Whoa! The Transaction global from the previous run was NEVER successfully",!,"written to an output device (unix uucppublic file, cartridge, diskette).",! W !,"You must execute the menu option called 'OUTP' before any further processing.",!,"You may also need to determine whether or not the transaction global for ",!,"LOG ENTRY ",BCH("LAST LOG")," was ever received by your Area Office.",! Q RERR ; S BCH("QFLG")=15 ; Q:$D(ZTQUEUED) W $C(7),$C(7),!!,"PCC Data Transmission is currently running!!" Q QERR ; S BCH("QFLG")=16 ; Q:$D(ZTQUEUED) W !!,$C(7),$C(7),"PCC Data Transmission is already queued to run!!" Q FERR ; S BCH("QFLG")=17 ; Q:$D(ZTQUEUED) W !!,$C(7),$C(7),"The last PCC Export failed and has never been reset.",!,"See your site manager for assistence",! Q ; DISPLOG ; DISPLAY LAST LOG DATA S Y=$P(^BCHXLOG(BCH("LAST LOG"),0),U) X ^DD("DD") S BCH("LAST BEGIN")=Y S Y=$P(^BCHXLOG(BCH("LAST LOG"),0),U,2) X ^DD("DD") S BCH("LAST END")=Y Q:$D(ZTQUEUED) W !!,"Last run was for ",BCH("LAST BEGIN")," through ",BCH("LAST END"),"." Q ; ; CHKCHR ; CHECK CHR RECORD "AEX" XREF S BCHR("R DATE")=0 S BCHR("R DATE")=$O(^BCHR("AEX",BCHR("R DATE"))) I $D(BCH("FIRST RUN")) D CHKCR Q:BCH("QFLG") ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - added this line S BCHR("R DATE")=$O(^BCHR("AEX",0)) I BCHR("R DATE"),BCHR("R DATE")BCH("RUN END")) W:'$D(ZTQUEUED) !!,"*** No CHR RECORDs within range! ***" S BCH("QFLG")=22 Q Q ; CONFIRM ; SEE IF THEY REALLY WANT TO DO THIS Q:$D(ZTQUEUED) W !,"The location for this run is ",$P(^DIC(4,DUZ(2),0),U),"." CFLP ; W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="N" K DA D ^DIR K DIR I $D(DIRUT) S BCH("QFLG")=99 I 'Y S BCH("QFLG")=99 Q ; GENLOG ; GENERATE NEW LOG ENTRY W:'$D(ZTQUEUED) !,"Generating New Log entry.." S BCH("BATCH")=$P(^BCHSITE(DUZ(2),0),U,11)+1 S Y=BCH("RUN BEGIN") X ^DD("DD") S X=""""_Y_"""",DIC="^BCHXLOG(",DIC(0)="L",DLAYGO=90002.91,DIC("DR")=".02////"_BCH("RUN END")_";.09///`"_DUZ(2)_";.11///"_BCH("BATCH") D ^DIC K DIC,DLAYGO,DR I Y<0 S BCH("QFLG")=23 Q S BCH("RUN LOG")=+Y K ^BCHRDATA ;TO DATA CENTER, THESE ARE OFFICIAL SCRATCH GLOBALS ;UNSUBSCRIPTED VARIABLES KILLED - THESE ARE CMB STANDARD DEFINED SCRATCH GLOBALS FOR TRANSMITTING DATA TO DATA CENTER Q CHKCR ; ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - added this sub-routine S Y=BCH("RUN BEGIN") X ^DD("DD") S Z=Y I BCHR("R DATE"),BCHR("R DATE")X) W "." K ^BCHR("AEX",BCH("DATE")) W !,"OK ALL DONE",! Q BCHEXLOG BCHEXLOG ; IHS/TUCSON/LAB - UPDATE LOG ; [ 06/03/99 6:43 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - new 0 node format for Y2K ; ; ; ; LOG ; UPDATE LOG W:'$D(ZTQUEUED) !!,BCH("COUNT")," transactions were generated." ;TUCSON/LAB added '$D(ZTQUEUED) patch 3 W:'$D(ZTQUEUED) !,"Updating log entry." D NOW^%DTC S BCH("RUN STOP")=% S ^BCHRDATA(0)=BCH("RUN LOCATION")_"^"_$P(^DIC(4,DUZ(2),0),U)_"^"_$$DATE($E(BCH("RUN START"),1,7))_"^"_$$DATE(BCH("RUN BEGIN"))_"^"_$$DATE(BCH("RUN END"))_"^^"_BCH("COUNT")_"^^" S $P(^BCHRDATA(1),U,2)=BCH("RUN LOCATION")_" "_$$LZERO^BCHEXD2(BCH("BATCH"),5)_" "_$$LZERO^BCHEXD2(BCH("COUNT"),5)_"B "_$P(BCH("RUN START"),".")_" "_$$RBLK^BCHEXD2($P(^DIC(4,DUZ(2),0),U),30)_" " ;SET BATCH NUMBER INTO SITE FILE FOR NEXT RUN S DA=DUZ(2),DIE="^BCHSITE(",DR=".11///"_BCH("BATCH") D ^DIE K DIE,DR,DA I $D(Y) S BCH("QFLG")=26 Q S DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".04////"_BCH("RUN STOP")_";.05////"_BCH("ERROR COUNT")_";.06////"_BCH("COUNT")_";.08///"_BCH("VISIT COUNT") D CALLDIE^BCHUTIL I $D(Y) S BCH("QFLG")=26 Q S DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".11////"_BCH("U")_";.13////"_BCH("D")_";.15///P;.17///"_BCH("BATCH") D CALLDIE^BCHUTIL I $D(Y) S BCH("QFLG")=26 Q K DR,DIE,DA,DIV,DIU ; Q ; DATE(D) ;EP convert date I $G(D)="" Q "" Q (1700+$E(D,1,3))_$E(D,4,7) ; BCHEXRE BCHEXRE ; IHS/TUCSON/LAB - REDO A PREVIOUS CHR EXPORT ; [ 06/03/99 6:46 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - $J to tmp START ; S BCHO("RUN")="REDO" ; Let ^BCHEXDI know this is a 'REDO' D ^BCHEXDI ; I BCH("QFLG") D EOJ W !!,"Bye",!! Q D INIT ; Get Log entry to redo I BCH("QFLG") D EOJ W !!,"Bye",!! Q D QUEUE^BCHEXDI I BCH("QFLG") D EOJ W !!,"Bye",!! Q I $D(BCHO("QUEUE")) D EOJ W !!,"Okay your request is queued!",!! Q ; EN ;EP FROM TASKMAN S BCHCNT=$S('$D(ZTQUEUED):"X BCHCNT1 X BCHCNT2",1:"S BCHCNTR=BCHCNTR+1"),BCHCNT1="F BCHCNTL=1:1:$L(BCHCNTR)+1 W @BCHBS",BCHCNT2="S BCHCNTR=BCHCNTR+1 W BCHCNTR,"")""" D NOW^%DTC S BCH("RUN START")=%,BCH("MAIN TX DATE")=$P(%,".") K %,%H,%I I BCH("QFLG") D:$D(ZTQUEUED) ABORT D EOJ Q S BCH("BT")=$HOROLOG D PROCESS ; Generate transactions I BCH("QFLG") W:'$D(ZTQUEUED) !!,"Abnormal termination! QFLG=",BCH("QFLG") D:$D(ZTQUEUED) ABORT D EOJ Q D ^BCHEXRLG ; Update Log entry I BCH("QFLG") W:'$D(ZTQUEUED) !!,"Log error! ",BCH("QFLG") D:$D(ZTQUEUED) ABORT D EOJ Q D:'$D(ZTQUEUED) RUNTIME^BCHEXEOJ I BCH("QFLG") W:'$D(ZTQUEUED) !!,"Tape creation error! QFLG=",BCH("QFLG") D:$D(ZTQUEUED) ABORT D EOJ Q D:'$D(ZTQUEUED) CHKLOG ; See if Log needs cleaning D RESETV ; Reset RECORDs processed in Log D TAPE ; Write transactions to tape I '$D(ZTQUEUED) K DIR W !! S DIR(0)="E",DIR("A")="DONE -- press any key to continue" K DA D ^DIR K DIR D EOJ K BCH Q ; PROCESS ; K ^BCHXLOG(BCH("RUN LOG"),51) S (BCH("U"),BCH("D"),BCH("COUNT"),BCH("ERROR COUNT"))=0 ;build header record S BCH("COUNT")=BCH("COUNT")+1,^BCHRDATA(BCH("COUNT"))="CR^" W:'$D(ZTQUEUED) !,"Generating transactions. Counting visits. (1)" S BCHCNTR=0 S BCHR=0 F S BCHR=$O(^BCHXLOG(BCH("RUN LOG"),21,BCHR)) Q:BCHR'=+BCHR S BCHRTYPE=$P(^BCHXLOG(BCH("RUN LOG"),21,BCHR,0),U,3) D PROCESS2 Q:BCH("QFLG") D DELETES Q PROCESS2 ; K BCHE,BCHCPOV X BCHCNT S ^TMP("BCHREDO",$J,"MAIN TX",BCHR)="",BCHV("TX GENERATED")=0 Q:'$D(^BCHR(BCHR)) I '$D(^BCHRPROB("AD",BCHR)) S BCHE="E021" D CNTBUILD Q S BCHREC=^BCHR(BCHR,0) K BCHE,BCHTX S (BCHCPOV,BCHPOVD)=0 F S BCHPOVD=$O(^BCHRPROB("AD",BCHR,BCHPOVD)) Q:BCHPOVD'=+BCHPOVD D .S BCHCPOV=BCHCPOV+1 .D RECORD^BCHEXD2 .D CNTBUILD .Q Q CNTBUILD ;EP - count and build tx I BCHE]"" S BCH("ERROR COUNT")=BCH("ERROR COUNT")+1 D ^BCHEXERR Q S BCH("COUNT")=BCH("COUNT")+1 S BCH(BCHRTYPE)=BCH(BCHRTYPE)+1 S BCHV("TX GENERATED")=1,^TMP("BCH"_$S(BCHO("RUN")="NEW":"DR",BCHO("RUN")="REDO":"REDO",1:"DR"),$J,"MAIN TX",BCHR)=BCH("MAIN TX DATE") S ^BCHRDATA(BCH("COUNT"))="CR^"_BCHTX SETUTIL S ^TMP("BCHREDO",$J,BCHR)=BCHR_U_BCHV("TX GENERATED")_U_BCHRTYPE Q ; TAPE ; COPY TRANSACTIONS TO TAPE D TAPE^BCHEXTAP Q DELETES ; D DELETES^BCHEXRE1 Q CHKLOG ; CHECK LOG FILE S BCH("X")=0 F BCH("I")=BCH("RUN LOG"):-1:1 Q:'$D(^BCHXLOG(BCH("I"))) I $O(^BCHXLOG(BCH("I"),21,0)) S BCH("X")=BCH("X")+1 I BCH("X")>3 W !!,"-->There are more than three generations of RECORDs stored in the LOG file.",!,"-->Time to do a purge." Q ; RESETV ; RESET RECORD DATA IN LOG W:'$D(ZTQUEUED) !,"Resetting RECORD specific data in Log file. (1)" S BCHCNTR=0 S BCH("X")="" F S BCH("X")=$O(^TMP("BCHREDO",$J,BCH("X"))) Q:BCH("X")'=+BCH("X") S BCH("Y")=^(BCH("X")),^BCHXLOG(BCH("RUN LOG"),21,BCH("X"),0)=BCH("Y") X BCHCNT W:'$D(ZTQUEUED) !,"Resetting RECORD TX Flags. (1)" S BCHCNTR=0 S BCH("X")="" F S BCH("X")=$O(^TMP("BCHREDO",$J,"MAIN TX",BCH("X"))) Q:BCH("X")'=+BCH("X") D .S DIE="^BCHR(",DA=BCH("X"),DR=".24///"_$S(^TMP("BCHREDO",$J,"MAIN TX",BCH("X"))]"":^TMP("BCHREDO",$J,"MAIN TX",BCH("X")),1:"@") D CALLDIE^BCHUTIL K DA,DR X BCHCNT .Q K ^TMP("BCHREDO") Q ; INIT ; D INIT^BCHEXRE1 Q ABORT ; ABNORMAL TERMINATION I $D(BCH("RUN LOG")) S BCH("QFLG1")=$O(^BCHERR("B",BCH("QFLG"),"")),DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".15///F;.16////"_BCH("QFLG1") I $D(ZTQUEUED) D ERRBULL^BCHEXDI3,ABORT,EOJ Q W !!,"Abnormal termination!! QFLG=",BCH("QFLG") S DIR(0)="E",DIR("A")="Press any key to continue" K DA D ^DIR K DIR Q ; EOJ ; D ^BCHEXEOJ Q BCHEXRE1 BCHEXRE1 ; IHS/TUCSON/LAB - CONT. OF REDO CHR EXPORT ; [ 06/03/99 6:47 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - added $J to ^TMP ; INIT ;EP D CHKOLD^BCHEXDI2 Q:BCH("QFLG") S DIC="^BCHXLOG(",DIC(0)="AEQ",DIC("S")="I $D(^(21)),$P(^(0),U,9)=DUZ(2)" D ^DIC K DIC I Y<0 S BCH("QFLG")=99 Q S BCH("RUN LOG")=+Y ; S X=^BCHXLOG(BCH("RUN LOG"),0),BCH("RUN BEGIN")=$P(X,U),BCH("RUN END")=$P(X,U,2),BCH("COUNT")=$P(X,U,6),BCH("ORIG TX DATE")=$P($P(X,U,3),"."),BCH("BATCH")=$P(X,U,17) S Y=BCH("RUN BEGIN") X ^DD("DD") S BCH("PRINT BEGIN")=Y S Y=BCH("RUN END") X ^DD("DD") S BCH("PRINT END")=Y S BCH("RECS")=$P(^BCHXLOG(BCH("RUN LOG"),21,0),U,4) W !!,"Log entry ",BCH("RUN LOG")," was for date range ",BCH("PRINT BEGIN")," through ",BCH("PRINT END"),!,"and generated ",BCH("COUNT")," transactions from ",BCH("RECS")," records." ; W !!!,$C(7),$C(7),"This routine will generate CHRIS II transactions.",! RDD ; S DIR(0)="Y",DIR("A")="Do you want to regenerate the transactions for this run",DIR("B")="N" K DA D ^DIR K DIR I $D(DIRUT) S BCH("QFLG")=99 Q I 'Y S BCH("QFLG")=99 Q Q DELETES ;EP S BCHRTYPE="D" S BCHR="" F S BCHR=$O(^BCHEXDEL("AD",BCH("ORIG TX DATE"),BCHR)) Q:BCHR="" D DELETES2 Q:BCH("QFLG") Q DELETES2 ; S BCHTX="" S BCHV("TX GENERATED")=0,^TMP("BCHREDO",$J,"DELETES",BCH("MAIN TX DATE"),BCHR)=BCH("MAIN TX DATE") X BCHCNT S X=$P(^BCHEXDEL(BCHR,0),U),X=$$LBLK^BCHEXD2(X,6) D TX^BCHEXD2 S X=$P(^BCHEXDEL(BCHR,0),U,2) S X=$$LBLK^BCHEXD2(X,7) D TX^BCHEXD2 S X=$P(^BCHEXDEL(BCHR,0),U,3) S X=$$LBLK^BCHEXD2(X,7) D TX^BCHEXD2 S X=$P(^BCHEXDEL(BCHR,0),U,4) S X=$$LZERO^BCHEXD2(X,3) D TX^BCHEXD2 S $E(BCHTX,68)=BCHRTYPE D CNTBUILD^BCHEXRE Q BCHEXRLG BCHEXRLG ; IHS/TUCSON/LAB - UPDATE LOG IN REDO AUGUST 14, 1992 ; [ 06/03/99 6:48 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - new 0 node format for export LOG ; UPDATE LOG W:'$D(ZTQUEUED) !!,BCH("COUNT")," transactions were generated." W:'$D(ZTQUEUED) !,"Updating Log entry." S ^BCHRDATA(0)=BCH("RUN LOCATION")_"^"_$P(^DIC(4,DUZ(2),0),U)_"^"_$$DATE^BCHEXLOG($E(BCH("RUN START"),1,7))_"^"_$$DATE^BCHEXLOG(BCH("RUN BEGIN"))_"^"_$$DATE^BCHEXLOG(BCH("RUN END"))_"^^"_BCH("COUNT")_"^^" S $P(^BCHRDATA(1),U,2)=BCH("RUN LOCATION")_" "_$$LZERO^BCHEXD2(BCH("BATCH"),5)_" "_$$LZERO^BCHEXD2(BCH("COUNT"),5)_"B "_$P(BCH("RUN START"),".")_" "_$$RBLK^BCHEXD2($P(^DIC(4,DUZ(2),0),U),30)_" " D NOW^%DTC S BCH("RUN STOP")=% S X=^BCHXLOG(BCH("RUN LOG"),0),$P(X,U,3)="",$P(X,U,4)="",$P(X,U,5)="",$P(X,U,6)="",$P(X,U,7)="",$P(X,U,11)="",$P(X,U,12)="",$P(X,U,13)="",$P(X,U,15)="",^BCHXLOG(BCH("RUN LOG"),0)=X S DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".03////"_BCH("RUN START")_";.04////"_BCH("RUN STOP")_";.05////"_BCH("ERROR COUNT")_";.06////"_BCH("COUNT")_";.15///P" D CALLDIE^BCHUTIL I $D(Y) S BCH("QFLG")=30 Q S DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".11////"_BCH("U")_";.13////"_BCH("D")_";.15///P" D CALLDIE^BCHUTIL I $D(Y) S BCH("QFLG")=30 Q Q ; ; BCHFC BCHFC ; IHS/TUCSON/LAB - COUNT FORMS REPORT ; [ 06/03/99 6:53 PM ] ;;1.0;IHS RPMS CHR SYSTEM;;OCT 28, 1996 ; START ; S BCHSITE="" S:$D(DUZ(2)) BCHSITE=DUZ(2) I '$D(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! K BCHSITE Q I 'DUZ(2) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER",!! K BCHSITE Q D INFORM GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Posting Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G XIT S BCHBD=Y ED ;get ending date W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ending Posting Date" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S BCHED=Y S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X ; DEC ; S DIR(0)="YO",DIR("A")="Report on ALL Operators",DIR("?")="If you wish to include visits entered by ALL Operators answer Yes. If you wish to tabulate for only one operator enter NO." D ^DIR K DIR G:$D(DIRUT) BD I Y=1 S BCHDEC="ALL" G ZIS DEC1 ;enter location S DIC("A")="Which Operator: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 DEC S BCHDEC=+Y ZIS ; S XBRP="^BCHFCP",XBRC="DRIVER^BCHFC",XBRX="XIT^BCHFC",XBNS="BCH" D ^XBDBQUE D XIT Q DRIVER ; entry point for taskman S BCHBT=$H S U="^" D XTMP^BCHUTIL("BCHFC","CHR FORMS COUNT") D ^BCHFC1 Q ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q XIT ; K DIC,%DT,IO("Q"),X,Y,POP,DIRUT,ZTSK,BCHH,BCHM,BCHS,BCHTS,ZTIO,%ZIS,%,DTOUT,DUOUT,X1,X2 K BCH1,BCH2,BCH80S,BCHAP,BCHBD,BCHBDD,BCHBT,BCHDATE,BCHDEC,BCHDT,BCHED,BCHEDD,BCHET,BCHGOT,BCHFC,BCHVDES,BCHTDES,BCHDESU,BCHX,BCHQUIT K BCHLENG,BCHODAT,BCHPG,BCHPROC,BCHPROV,BCHSD,BCHSITE,BCHSORT,BCHSRT,BCHSUB,BCHTOT,BCHVSIT,BCHVREC,BCHWDAT,BCHY,BCHC,BCHDFN,BCHAVG,BCHDEC Q ; INFORM ; W:$D(IOF) @IOF W !,"This report will generate a count of forms entered by a particular data entry",!,"operator or for ALL data entry operators for a date range that you specify.",! Q ; BCHFC1 BCHFC1 ; IHS/TUCSON/LAB - FORMS COUNT (FILE) report process ; [ 06/03/99 6:54 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp P ; Run by posting date S BCHH=$H,BCHJOB=$J S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("AD",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D V1 S BCHET=$H D EOJ Q V1 ; S BCHVSIT="" F S BCHVSIT=$O(^BCHR("AD",BCHODAT,BCHVSIT)) Q:BCHVSIT'=+BCHVSIT I $D(^BCHR(BCHVSIT,0)) D PROC Q PROC ; I BCHDEC'="ALL",BCHDEC'=$P(^BCHR(BCHVSIT,0),U,16) Q Q:$P(^BCHR(BCHVSIT,0),U,16)="" Q:'$D(^VA(200,$P(^BCHR(BCHVSIT,0),U,16),0)) S BCHAP=$P(^VA(200,$P(^BCHR(BCHVSIT,0),U,16),0),U) S BCHVREC=^BCHR(BCHVSIT,0) S BCHDATE=$P(BCHODAT,".") SET S ^(BCHDATE)=$S($D(^XTMP("BCHFC",BCHJOB,BCHH,BCHAP,BCHDATE)):^(BCHDATE)+1,1:1) Q EOJ ; clean up and exit K BCHVREC,BCHCLIN,BCHSKIP,BCH1,BCH2,BCHAP,BCHX,BCHY,BCHVDES,BCHDATE,BCHPROV,BCHSEC,BCHZ Q ; ; BCHFCP BCHFCP ; IHS/TUCSON/LAB - PRINT FORMS COUNT REPORT ; [ 06/03/99 7:04 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; S BCH80S="-------------------------------------------------------------------------------",BCHPG=0 S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S (BCHTOT,BCHPROV,BCHTDES)=0 K BCHQUIT I '$D(^XTMP("BCHFC",BCHJOB,BCHH)) S BCHPROV="NONE TO REPORT" D HEAD G DONE F S BCHPROV=$O(^XTMP("BCHFC",BCHJOB,BCHH,BCHPROV)) Q:BCHPROV=""!($D(BCHQUIT)) D HEAD Q:$D(BCHQUIT) D SORT G:$D(BCHQUIT) DONE I $Y>(IOSL-5) D HEAD G:$D(BCHQUIT) DONE W !?42,"------",! W ?5,"Grand Total for ALL Operators:",?42,$J(BCHTOT,6) D SUMMPAGE DONE I $D(BCHET) S BCHTS=(86400*($P(BCHET,",")-$P(BCHBT,",")))+($P(BCHET,",",2)-$P(BCHBT,",",2)),BCHH=$P(BCHTS/3600,".") S:BCHH="" BCHH=0 S BCHTS=BCHTS-(BCHH*3600),BCHM=$P(BCHTS/60,".") S:BCHM="" BCHM=0 S BCHTS=BCHTS-(BCHM*60),BCHS=BCHTS W !!,"RUN TIME (H.M.S): ",BCHH,".",BCHM,".",BCHS I $E(IOST)="C",IO=IO(0) S DIR(0)="E" D ^DIR K DIR W:$D(IOF) @IOF K ^XTMP("BCHFC",BCHJOB,BCHH),BCHJOB,BCHH Q SORT ; S (BCHSUB,BCHDESU)=0,BCHFC("DAYS",BCHPROV)=0 S BCHDATE=0 F S BCHDATE=$O(^XTMP("BCHFC",BCHJOB,BCHH,BCHPROV,BCHDATE)) Q:BCHDATE'=+BCHDATE!($D(BCHQUIT)) D WRITE W !?42,"------",! W ?5,"Totals for ",BCHPROV,?42,$J(BCHSUB,6) S BCHFC("FORMS",BCHPROV)=BCHSUB Q WRITE ; S Y=BCHDATE D DD^%DT S BCHWDAT=Y I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) W ?25,BCHWDAT,?42,$J(^XTMP("BCHFC",BCHJOB,BCHH,BCHPROV,BCHDATE),6),! S BCHSUB=BCHSUB+^XTMP("BCHFC",BCHJOB,BCHH,BCHPROV,BCHDATE),BCHTOT=BCHTOT+^XTMP("BCHFC",BCHJOB,BCHH,BCHPROV,BCHDATE) S BCHFC("DAYS",BCHPROV)=BCHFC("DAYS",BCHPROV)+1 Q SUMMPAGE ; I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q W:$D(IOF) @IOF S BCHPG=BCHPG+1 W !?58,$$FMTE^XLFDT(DT),?70,"Page ",BCHPG W !?20,"SUMMARY OF FORMS KEYED BY ALL OPERATORS" W !?15,"CHR RECORD POSTING DATES: ",BCHBDD," TO ",BCHEDD,! W !?35,"No. of",?43,"Forms",?53,"% of" W !?11,"Operator",?35,"Forms",?43,"per day",?53,"Workload" W !,BCH80S S X="" F S X=$O(BCHFC("FORMS",X)) Q:X="" W !,X,?32,$J(BCHFC("FORMS",X),8),?40,$J((BCHFC("FORMS",X)/BCHFC("DAYS",X)),8,2),?51,$J(((BCHFC("FORMS",X)/BCHTOT)*100),8,2) ;S X="" F S X=$O(BCHFC("FORMS",X)) Q:X="" W !,X,?32,$J(BCHFC("FORMS",X),8),?40,$J(((BCHFC("FORMS",X)/BCHFC("DAYS",X)),8),?51,$J((((BCHFC("FORMS",X)/BCHTOT)*100),8) W !?35,"--------",!?32,$J(BCHTOT,8) Q HEAD I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; W @IOF S BCHPG=BCHPG+1 W !?58,$$FMTE^XLFDT(DT),?70,"Page ",BCHPG,! S BCHLENG=$L($P(^DIC(4,DUZ(2),0),U)) W ?((80-BCHLENG)/2),$P(^DIC(4,DUZ(2),0),U),! W ?29,"NUMBER OF FORMS KEYED",! S BCHLENG=21+$L(BCHPROV) W ?((80-BCHLENG)/2),"DATE ENTRY OPERATOR: ",BCHPROV,! W ?15,"CHR RECORD POSTING DATES: ",BCHBDD," TO ",BCHEDD,! W !?25,"POSTING DATE",?40,"# FORMS",! W BCH80S,! Q BCHHS BCHHS ; IHS/TUCSON/LAB - CHR HEALTH SUMMARY CALL ; [ 06/03/97 12:34 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ;IHS/TUCSON/LAB - patch 2 - added line EN+2 to go to full screen ;from list man - 06/03/97 ; ;Called to generate a CHR Health Summary Type. ; EN ;EP ; generate health summary from protocol D FULL^VALM1 ;IHS/TUCSON/LAB - patch 2 added this line D GETPAT I 'APCHSPAT D EXIT Q D GETTYPE I 'APCHSTYP D EXIT Q D EN^APCHS W ! S DIR(0)="E",DIR("A")="End of Health Summary Display. Hit return." K DA D ^DIR K DIR D EXIT Q ;GET PATIENT GETPAT ; S APCHSPAT="" S DIC("A")="Enter PATIENT Name: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S APCHSPAT=+Y Q ; GETTYPE ; S APCHSTYP=$O(^APCHSCTL("B","CHR",0)) I 'APCHSTYP W !!,$C(7),$C(7),"The CHR Health Summary type is Missing. You need version 2.0 of Health Summary.",! H 4 Q I '$D(^APCHSCTL(APCHSTYP)) W !,"Error in Health Summary file!",$C(7),$C(7) S APCHSTYP="" Q Q ; EXIT ;EP S VALMBCK="R" D GATHER^BCHUARL S VALMCNT=BCHRCNT D HDR^BCHUAR K BCHV,BCHF,BCHDR,APCHSPAT,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT Q BCHRAP2P BCHRAP2P ; IHS/TUCSON/LAB - print all visit report ; [ 06/05/99 7:50 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ;Print routine. ; PRINT ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y D COVPAGE^BCHRPTCP S (BCHTOT,BCHPG,BCHPTOT,BCHTTOT)=0 D HEAD K BCHQUIT D SORT G:$D(BCHQUIT) DONE I $Y>(IOSL-5) D HEAD G:$D(BCHQUIT) DONE W !?47,"--------",?56,"--------",?68,"--------",! W ?32,"Totals:",?45,$J(BCHTOT,8),?54,$J(BCHPTOT,8) S X=BCHTTOT,X=$J((X/60),6,1) W ?66,$J(X,8) DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRAP2",BCHJOB,BCHBTH) K BCHBT,BCHET Q SORT ; I $Y>(IOSL-6) D HEAD Q:$D(BCHQUIT) S BCHSORT="" F S BCHSORT=$O(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TOTAL",BCHSORT)) Q:BCHSORT=""!($D(BCHQUIT)) D P Q P ; I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) S BCHSRT2=$O(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TOTAL",BCHSORT,"")) S BCHPRNT=BCHSORT I BCHRPROC="DATE" S Y=BCHPRNT D DD^%DT S BCHPRNT=Y W !,$E(BCHPRNT,1,25) W ?28,$E(BCHSRT2,1,15),?45,$J(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TOTAL",BCHSORT,BCHSRT2),8) W ?54,$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"PATIENT",BCHSORT,BCHSRT2)):$J(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"PATIENT",BCHSORT,BCHSRT2),8),1:$J(0,8)) I $D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TIME TOTAL",BCHSORT,BCHSRT2)) S X=^(BCHSRT2),X=$J((X/60),1,1) W ?66,$J(X,8) S BCHTOT=BCHTOT+^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TOTAL",BCHSORT,BCHSRT2) S BCHPTOT=BCHPTOT+$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"PATIENT",BCHSORT,BCHSRT2)):^(BCHSRT2),1:0) S BCHTTOT=BCHTTOT+$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TIME TOTAL",BCHSORT,BCHSRT2)):^(BCHSRT2),1:0) Q HEAD I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; W:$D(IOF) @IOF S BCHPG=BCHPG+1 W ! W ?58,BCHDT,?72,"Page ",BCHPG,! W ?17,"RECORD DATES: ",BCHBDD," TO ",BCHEDD,! S BCHLENG=30+$L(BCHTITL) W ?((80-BCHLENG)/2),"NUMBER OF ACTIVITY RECORDS BY ",BCHTITL,! W !,BCHHD1,?28,$E(BCHHD2,1,13),?47,"# RECS",?56,"# CONTS",?64,"ACTIVITY TIME",! W !,$TR($J(" ",80)," ","-") Q BCHRC11 BCHRC11 ; IHS/TUCSON/LAB - PROCESS REPORT ; [ 06/05/99 8:38 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; ; ; START ; S (BCHBT,BCHBTH)=$H,BCHJOB=$J D XTMP^BCHUTIL("BCHRC1","CHR CHRIS II REPORT") D D,END Q ; D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; END ; S BCHET=$H D EOJ Q EOJ ; Q D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROC Q PROC ; S BCHPROG=$P(BCHR0,U,2) I BCHPRG,BCHPRG'=BCHPROG Q S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHC=BCHC+1 I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)'="LT" D @BCHRPT D .S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1) .S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+$P(^BCHRPROB(BCHX,0),U,5) .I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+$P(BCHR0,U,11) .S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$P(BCHR0,U,12) .S $P(^("*TOTAL*"),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*")):$P(^("*TOTAL*"),U)+1,1:1) .S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)+$P(^BCHRPROB(BCHX,0),U,5) .I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)+$P(BCHR0,U,11) .S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$P(BCHR0,U,12) Q 1 ;health area S BCHPROB=$P(^BCHRPROB(BCHX,0),U),BCHPROBN=$P(^BCHTPROB(BCHPROB,0),U)_"|"_$P(^BCHTPROB(BCHPROB,0),U,2) Q 2 ;activity S BCHPROB=$P(^BCHRPROB(BCHX,0),U,4) I BCHPROB="" S BCHPROBN="NO ACTIVITY ENTERED|**" Q S BCHPROBN=$P(^BCHTSERV(BCHPROB,0),U)_"|"_$P(^BCHTSERV(BCHPROB,0),U,3) Q 3 ;setting S BCHPROB=$P(BCHR0,U,6) I BCHPROB="" S BCHPROBN="NO SETTING ENTERED|**" Q S BCHPROBN=$P(^BCHTACTL(BCHPROB,0),U)_"|"_$P(^(0),U,5) Q BCHRC1P BCHRC1P ; IHS/TUCSON/LAB - print all visit report ; [ 06/05/99 8:39 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y K BCHQUIT S BCHPG=0 S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y I '$D(^XTMP("BCHRC1",BCHJOB,BCHBTH,"DATA")) D HEAD W !!,"NO DATA TO REPORT",!! G DONE HA ; D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ;set total numbers and print S BCHTOTS=($P(^XTMP("BCHRC1",BCHJOB,BCHBTH,"DATA","*TOTAL*"),U,2)/60),BCHTOTA=$P(^("*TOTAL*"),U),BCHTOTC=$P(^("*TOTAL*"),U,4),BCHTOTT=($P(^("*TOTAL*"),U,3)/60) I $Y>(IOSL-3) D HEAD G:$D(BCHQUIT) DONE W !?4,"TOTAL",?28,$J($FN(BCHTOTS,",",0),6),?35,"100%",?41,$J($FN(BCHTOTT,",",0),5),?47,"100%",?54,$J($FN(BCHTOTC,",",0),5),?60,"100%",?67,$J($FN(BCHTOTA,",",0),5),?73,"100%",! S BCHHA="*Z" F S BCHHA=$O(^XTMP("BCHRC1",BCHJOB,BCHBTH,"DATA",BCHHA)) Q:BCHHA=""!($D(BCHQUIT)) D .S BCHCS=($P(^XTMP("BCHRC1",BCHJOB,BCHBTH,"DATA",BCHHA),U,2)/60),BCHCA=$P(^(BCHHA),U),BCHCC=$P(^(BCHHA),U,4),BCHCT=($P(^(BCHHA),U,3)/60) .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,$P(BCHHA,"|",2)," ",$E($P(BCHHA,"|"),1,22) .W ?29,$J(BCHCS,5,0) W ?35,$S(BCHTOTS:$J(((BCHCS/BCHTOTS)*100),3,0),1:$J("0",3,0)),"%" .W ?41,$J(BCHCT,5,0),?47,$S(BCHTOTT:$J(((BCHCT/BCHTOTT)*100),3,0),1:$J("0",3,0)),"%" .W ?54,$J(BCHCC,5),?60,$S(BCHTOTC:$J(((BCHCC/BCHTOTC)*100),3,0),1:$J("0",3,0)),"%" .W ?67,$J(BCHCA,5),?73,$S(BCHTOTA:$J(((BCHCA/BCHTOTA)*100),3,0),1:$J("0",3,0)),"%" .Q DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRC1",BCHJOB,BCHBTH),BCHJOB,BCHBTH Q HEAD ; I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; W:$D(IOF) @IOF HEAD2 ; S BCHPG=BCHPG+1 W !,$P(^VA(200,DUZ,0),U,2),?58,BCHDT,?72,"Page ",BCHPG,! W !?20,"********** CHR REPORT NO. ",BCHRPT," **********" W !!?((80-($L(BCHCH)+47))/2),"TIME SPENT, CLIENT CONTACTS, AND ACTIVITIES by ",BCHCH S BCHPROGN=$S(BCHPRG:$P(^BCHTPROG(BCHPRG,0),U)_" ("_$P(^(0),U,5)_")",1:"ALL"),X=$L(BCHPROGN)+10 W !!?((80-X)/2),"PROGRAM: ",BCHPROGN W !?17,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !?3,BCHCH,?31,"SERVICE",?44,"TRAVEL",?56,"CLIENT",?67,"ACTIVITIES" W !?31,"HOURS",?44,"HOURS",?56,"CONTACTS" W !,$TR($J(" ",80)," ","-") Q BCHRC2 BCHRC2 ; IHS/TUCSON/LAB - CHRIS II Report 2 ; [ 06/05/99 8:41 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q S BCHJOB=$J,BCHBTH=$H D INFORM GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter BEGINNING Date of Service for Report" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G XIT S BCHBD=Y ED ;get ending date W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ENDING Date of Service for Report" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S BCHED=Y S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X ; PROG ; S BCHPRG="" S DIR(0)="Y",DIR("A")="Include data from ALL CHR Programs",DIR("?")="If you wish to include visits from ALL programs answer Yes. If you wish to tabulate for only one program enter NO." D ^DIR K DIR G:$D(DIRUT) BD I Y=1 S BCHPRG="" G ZIS PROG1 ;enter program K X,DIC,DA,DD,DR,Y S DIC("A")="Which CHR Program: ",DIC="^BCHTPROG(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 PROG S BCHPRG=+Y ZIS ;CALL TO XBDBQUE S XBRP="^BCHRC2P",XBRC="PROC^BCHRC2",XBRX="XIT^BCHRC2",XBNS="BCH" D ^XBDBQUE D XIT Q ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q XIT ; K BCHPRG,BCHTT,BCHFT,BCHF,BCHT,BCHREF,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHR,BCHR0,BCHPG,BCHDT K X,Y Q ; INFORM ; W:$D(IOF) @IOF W !?20,"********** CHR REPORT NO. 4 **********" W !!?26,"NUMBER OF REFERRALS FROM/TO",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!! Q ; ; PROC ;EP - PROCESS REFERRAL REPORT D XTMP^BCHUTIL("BCHRC2","CHR CHRIS II REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J S X=0 F S X=$O(^BCHTREF(X)) Q:X'=+X S ^XTMP("BCHRC2",BCHJOB,BCHBT,X,"FROM")=0,^XTMP("BCHRC2",BCHJOB,BCHBT,X,"TO")=0 S ^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")=0,^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")=0 D D,EOJ Q ; EOJ ; S BCHET=$H Q D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROCESS Q PROCESS ; S BCHPROG=$P(BCHR0,U,2) I BCHPRG,BCHPRG'=BCHPROG Q S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)'=99 S BCHC=BCHC+1 Q:'BCHC ;if none are not travel do not count S BCHREF=$P(BCHR0,U,7) I BCHREF S ^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"FROM")=^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"FROM")+$P(BCHR0,U,12),^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")+$P(BCHR0,U,12) S BCHREF=$P(BCHR0,U,8) I BCHREF S ^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"TO")=^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"TO")+$P(BCHR0,U,12),^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")+$P(BCHR0,U,12) Q BCHRC2P BCHRC2P ; IHS/TUCSON/LAB - = print all visit report ; [ 06/05/99 8:41 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y I '$D(^XTMP("BCHRC2",BCHJOB,BCHBTH)) W !!,"NO DATA TO REPORT",!! G DONE K BCHQUIT S BCHPG=0 REF ; D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ;set total numbers and print I $Y>(IOSL-3) D HEAD G:$D(BCHQUIT) DONE W !?4,"TOTAL",?26,$J($FN(^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM"),","),5),?32,"100%" W ?46,"TOTAL",?69,$J($FN(^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO"),","),5),?75,"100%" S BCHFT=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM"),BCHTT=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO") S BCHREF=0 F S BCHREF=$O(^XTMP("BCHRC2",BCHJOB,BCHBTH,BCHREF)) Q:BCHREF'=+BCHREF!($D(BCHQUIT)) D .S BCHF=^XTMP("BCHRC2",BCHJOB,BCHBTH,BCHREF,"FROM") .S BCHT=^XTMP("BCHRC2",BCHJOB,BCHBTH,BCHREF,"TO") .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,$P(^BCHTREF(BCHREF,0),U,3)," ",$E($P(^(0),U),1,20),?26,$J(BCHF,5),?32,$S(BCHFT:$J(((BCHF/BCHFT)*100),3,0),1:$J("0",3,0)),"%" .W ?44,$P(^BCHTREF(BCHREF,0),U,3)," ",$E($P(^(0),U),1,20),?69,$J(BCHT,5),?75,$S(BCHTT:$J(((BCHT/BCHTT)*100),3,0),1:$J("0",3,0)),"%" .Q DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRC2",BCHJOB,BCHBTH),BCHJOB,BCHBTH Q HEAD ; I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF ; HEAD2 ; if printer S BCHPG=BCHPG+1 ;W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********" W !,$P(^VA(200,DUZ,0),U,2),?58,BCHDT,?72,"Page ",BCHPG,! W !?20,"********** CHR REPORT NO. 4 **********" W !!?26,"NUMBER OF REFERRALS FROM/TO" S BCHPROGN=$S(BCHPRG:$P(^BCHTPROG(BCHPRG,0),U)_" ("_$P(^(0),U,5)_")",1:"ALL"),X=$L(BCHPROGN)+10 W !!?((80-X)/2),"PROGRAM: ",BCHPROGN W !?17,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !,"REFERRALS TO CHR FROM",?25,"# REFERRALS",?44,"REFERRALS BY CHR TO",?69,"# REFERRALS" W !,$TR($J(" ",80)," ","-") Q BCHRC51 BCHRC51 ; IHS/TUCSON/LAB - PROCESS REPORT ; [ 06/05/99 8:42 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; START ; D XTMP^BCHUTIL("BCHRC5","CHR CHRIS II REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J,BCHTF=0,BCHTM=0 S BCHRNN=BCHRBIN,BCHRA="" F I=1:1 S BCHRX=$P(BCHRNN,";",I) Q:BCHRX="" D SETA S BCHRDOBS=BCHRA D D,END Q ; D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; END ; S BCHET=$H D EOJ Q EOJ ; Q D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0),BCHR11=$G(^BCHR(BCHR,11)) D PROC Q PROC ; S BCHPROG=$P(BCHR0,U,2) I BCHPRG,BCHPRG'=BCHPROG Q ;S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHC=BCHC+1 D S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)'="LT" S BCHC=BCHC+1 D .S BCHPROB=$P(^BCHRPROB(BCHX,0),U),BCHPROBN=$P(^BCHTPROB(BCHPROB,0),U)_"|"_$P(^BCHTPROB(BCHPROB,0),U,2) .D SETTMP .Q Q SETTMP ; S DFN=$P(BCHR0,U,4) I DFN S DOB=$P(^DPT(DFN,0),U,3) I 'DFN S DOB=$P(BCHR11,U,2) Q:DOB']"" I DFN S SEX=$P(^DPT(DFN,0),U,2) I 'DFN S SEX=$P(BCHR11,U,3) Q:SEX="" ;no sex available Q:$P(BCHR0,U,12)'=1 S BCHRAGE="" D GETAGE Q:'BCHRAGE I SEX="F" S BCHTF=BCHTF+1 I SEX="M" S BCHTM=BCHTM+1 S ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHRAGE,SEX)=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHRAGE,SEX)+1 S ^(SEX)=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHPROB,BCHRAGE,SEX)):^(SEX)+1,1:1) S ^(SEX)=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHPROB,"TOTAL",SEX)):^(SEX)+1,1:1) Q GETAGE ; F I=1:1 S BCHRNN=$P(BCHRA,";",I) Q:BCHRNN="" S BCHRX=$P(BCHRNN,"-"),BCHRY=$P(BCHRNN,"-",2) I DOB'BCHRY S BCHRAGE=I Q Q ; SETA ; S BCHRY=$P(BCHRX,"-"),BCHRZ=$P(BCHRX,"-",2) I BCHRA]"" S BCHRA=BCHRA_";" S BCHRA=BCHRA_(DT+1-(10000*(BCHRZ+1)))_"-"_(DT-(BCHRY*10000)) S ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",I,"F")=0,^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",I,"M")=0 Q BCHRC5P BCHRC5P ; IHS/TUCSON/LAB - print dx by age ; [ 06/05/99 8:42 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S Y=DT D DD^%DT S BCHDT=Y ;S BCHPG=0 D HEAD S BCHPG=0 K BCHQUIT I '$D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA")) W !!,"NO DATA TO REPORT" G DONE HA ; D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ; LAB ; I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE W !?4,"TOTAL",?29,$J(BCHTM,5),?36,$J(BCHTF,5) S BCHX=0,J=45 F S BCHX=$O(^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT)) D .S M=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX,"M"),F=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX,"F") .W ?J,$J(M,5) S J=J+7 W ?J,$J(F,5) S J=J+7 .Q S BCHX=0 F S BCHX=$O(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,$P(^BCHTPROB(BCHX,0),U,2)," ",$P(^BCHTPROB(BCHX,0),U) .S M=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,"TOTAL","M")):^("M"),1:0),F=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,"TOTAL","F")):^("F"),1:0) W ?29,$J(M,5),?36,$J(F,5) .S J=45 F I=1:1:$L(BCHRBIN,";") S M=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,I,"M")):^("M"),1:"."),F=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,I,"F")):^("F"),1:".") W ?J,$J(M,5) S J=J+7 W ?J,$J(F,5) S J=J+7 ; DONE D DONE^BCHUTIL1 K ^XTMP("BCHRC5",BCHJOB,BCHBT),BCHJOB,BCHBT,BCHX Q HEAD ; I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF HEAD2 ; if printer S BCHPG=BCHPG+1 W !,$P(^VA(200,DUZ,0),U,2),?56,"DATE GENERATED: ",BCHDT,?124,"Page ",BCHPG,! W !?46,"********** CHR REPORT NO. 5 **********" W !!?44,"CLIENT CONTACTS BY HEALTH PROBLEM, AGE AND SEX" S BCHPROGN=$S(BCHPRG:$P(^BCHTPROG(BCHPRG,0),U)_" ("_$P(^(0),U,5)_")",1:"ALL"),X=$L(BCHPROGN)+10 W !!?((132-X)/2),"PROGRAM: ",BCHPROGN W !?43,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !,"HEALTH PROBLEM",?28,"---ALL AGES---" S J=50 F I=1:1:$L(BCHRBIN,";") S K=$P(BCHRBIN,";",I) Q:K="" W ?J,K S J=J+14 ;W !,"HEALTH PROBLEM",?28,"---ALL AGES---",?50,"0-4",?64,"5-9",?77,"10-19",?93,"20-34",?108,"35-54",?123,"55+" ;W !?32,"M F" S J=48 F I=1:1:$L(BCHRBIN,";") W ?J,"M F" S J=J+$S($P(BCHRBIN,";",I)>3:15,1:14) W !?32,"M F" S J=48 F I=1:1:$L(BCHRBIN,";") W ?J,"M F" S J=J+14 ;W !?32,"M F",?47,"M F",?62,"M F",?76,"M F",?92,"M F",?107,"M F",?121,"M F" W !,$TR($J(" ",132)," ","-") Q BCHRC6 BCHRC6 ; IHS/TUCSON/LAB - CHRIS II Report 2 ; [ 06/05/99 8:44 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q S BCHJOB=$J,BCHBTH=$H D INFORM GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter BEGINNING Date of Service for Report" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G XIT S BCHBD=Y ED ;get ending date W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ENDING Date of Service for Report" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S BCHED=Y S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X ; PROG ; S BCHPRG="" S DIR(0)="Y",DIR("A")="Include data from ALL CHR Programs",DIR("?")="If you wish to include visits from ALL programs answer Yes. If you wish to tabulate for only one program enter NO." D ^DIR K DIR G:$D(DIRUT) BD I Y=1 S BCHPRG="" G ZIS PROG1 ;enter program K X,DIC,DA,DD,DR,Y S DIC("A")="Which CHR Program: ",DIC="^BCHTPROG(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 PROG S BCHPRG=+Y ZIS ;CALL TO XBDBQUE S XBRP="^BCHRC6P",XBRC="PROC^BCHRC6",XBRX="XIT^BCHRC6",XBNS="BCH" D ^XBDBQUE D XIT Q ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q XIT ; F X=1:1:10 S V="V"_X K @V K V,BCHSD,BCHBD,BCHBDD,BCHED,BCHEDD,BCHODAT,BCHR,BCHR0,X,P,S,N,BCHQUIT,BCHBTH,BCHDT,BCHNAME,BCHPRG,BCHX K X,Y Q ; INFORM ; W:$D(IOF) @IOF W !?20,"********** CHR REPORT NO. 6 **********" W !!?33,"PROVIDER DATA",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!! W "THIS REPORT REQUIRES A PRINTER THAT IS CAPABLE OF PRINTING 132 COLUMN OUTPUT.",!,"SEE YOUR SITE MANAGER IF YOU NEED ASSISTANCE FINDING SUCH A PRINTER.",!! Q ; ; PROC ;EP - PROCESS REFERRAL REPORT D XTMP^BCHUTIL("BCHRC6","CHR CHRIS II REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J S ^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL")=0 D D,EOJ Q ; EOJ ; S BCHET=$H Q D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROCESS Q PROCESS ; S BCHPROG=$P(BCHR0,U,2) I BCHPRG,BCHPRG'=BCHPROG Q S C=$P(BCHR0,U,3),BCHNAME=$P(^VA(200,C,0),U) I '$D(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME)) S ^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME)=0 S X=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X D .S S=$P(^BCHRPROB(X,0),U,4) Q:S="" .I $P(^BCHTSERV(S,0),U,3)="LT" D ..S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,3)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,3)+$P(^BCHRPROB(X,0),U,5) ..S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,3)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,3)+$P(^BCHRPROB(X,0),U,5) .E S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U)+$P(^BCHRPROB(X,0),U,5),$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U)+$P(^BCHRPROB(X,0),U,5) .S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)+$P(^BCHRPROB(X,0),U,5) .S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(^BCHRPROB(X,0),U,5) .Q S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,2)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,2)+$P(BCHR0,U,11) S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)+$P(BCHR0,U,11) S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(BCHR0,U,11) S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,2)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,2)+$P(BCHR0,U,11) S N=$P(BCHR0,U,12),P=$S('N:5,N=1:6,1:7) S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,P)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,P)+1,$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,P)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,P)+1 I N>1 S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,10)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,10)+N,$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,10)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,10)+N S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,9)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,9)+N,$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,9)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,9)+N Q BCHRC6P BCHRC6P ; IHS/TUCSON/LAB - print dx by age ; [ 06/05/99 8:44 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S Y=DT D DD^%DT S BCHDT=Y S BCHPG=0 K BCHQUIT I '$D(^XTMP("BCHRC6",BCHJOB,BCHBT)) W !!,"NO DATA TO REPORT" G DONE ; D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ; I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE W !,"TOTAL" F I=1:1:10 S V="V"_I S @V=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,I) S V1=V1/60 W ?25,$J($FN(V1,",",0),10) S V2=V2/60 W ?37,$J($FN(V2,",",0),10) S V3=V3/60 W ?49,$J($FN(V3,",",0),10) S V4=V4/60 W ?61,$J($FN(V4,",",0),10) W ?73,$J($FN(V5,",",0),10) W ?85,$J($FN(V6,",",0),10) W ?97,$J($FN(V7,",",0),10) S V8=$S(V7:V10/V7,1:0) W ?109,$J($FN(V8,",",1),10) W ?121,$J($FN(V9,",",0),10) PROV ;print each provider S BCHX="" F S BCHX=$O(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHX)) Q:BCHX=""!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE .W !,$E(BCHX,1,24) .F I=1:1:10 S V="V"_I S @V=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHX),U,I) .S V1=V1/60 W ?25,$J($FN(V1,",",0),10) .S V2=V2/60 W ?37,$J($FN(V2,",",0),10) .S V3=V3/60 W ?49,$J($FN(V3,",",0),10) .S V4=V4/60 W ?61,$J($FN(V4,",",0),10) .W ?73,$J($FN(V5,",",0),10) .W ?85,$J($FN(V6,",",0),10) .W ?97,$J($FN(V7,",",0),10) .S V8=$S(V7:V10/V7,1:0) W ?109,$J($FN(V8,",",1),10) .W ?121,$J($FN(V9,",",0),10) DONE D DONE^BCHUTIL1 K ^XTMP("BCHRC6",BCHJOB,BCHBT),BCHJOB,BCHBT Q HEAD ; I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF HEAD2 ; if printer S BCHPG=BCHPG+1 W !,$P(^VA(200,DUZ,0),U,2),?56,"DATE GENERATED: ",BCHDT,?124,"Page ",BCHPG,! W !?46,"********** CHR REPORT NO. 6 **********" W !!?59,"PROVIDER DATA" S BCHPROGN=$S(BCHPRG:$P(^BCHTPROG(BCHPRG,0),U)_" ("_$P(^(0),U,5)_")",1:"ALL"),X=$L(BCHPROGN)+10 W !!?((132-X)/2),"PROGRAM: ",BCHPROGN W !?43,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !!?25," SERVICE",?37," TRAVEL",?49," LEAVE",?61," TOTAL",?73,"0 NUM SERV",?85,"1 NUM SERV",?97," GROUP",?109," AVERAGE",?121,"TOT NUMBER" W !,"PROVIDER",?25," HOURS",?37," HOURS",?49," HOURS",?61," HOURS",?73,"ACTIVITIES",?85,"ACTIVITIES",?97,"ACTIVITIES",?109," GRP SIZE",?121," SERVED" W !,$TR($J(" ",132)," ","-") Q BCHRC8 BCHRC8 ; IHS/TUCSON/LAB - CHRIS II Report 2 ; [ 06/05/99 8:52 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q S BCHJOB=$J,BCHBTH=$H D INFORM GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter BEGINNING Date of Service for Report" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G XIT S BCHBD=Y ED ;get ending date W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ENDING Date of Service for Report" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S BCHED=Y S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X ; TYPE ; S BCHRPT="" S DIR(0)="S^PG:By PROGRAM (Report 8);PR:By PROVIDER (Report 8.2)",DIR("A")="Which report do you wish to run",DIR("B")="PG" K DA D ^DIR K DIR I $D(DIRUT) G GETDATES S BCHRPT=Y D @Y ZIS ;CALL TO XBDBQUE S XBRP="^BCHRC8P",XBRC="PROC^BCHRC8",XBRX="XIT^BCHRC8",XBNS="BCH" D ^XBDBQUE D XIT Q ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q XIT ; K BCHPRG,BCHNONE,BCHFT,BCHF,BCHT,BCHREF,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHR,BCHR0,BCHPG,BCHDT,BCHIDAT,BCHMON,BCHTOT,BCHCH,BCHITEM,BCHNAME,BCHRN,BCHRPT,BCHBRK,BCHEOJ K M,R,V,X,Y,I K X,Y Q ; INFORM ; W:$D(IOF) @IOF W !?20,"********** CHR REPORT NO. 8 **********" W !!?20,"HOURS (SERVICE+TRAVEL) BY MONTH",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!! Q ; ; PROC ;EP - PROCESS REFERRAL REPORT D XTMP^BCHUTIL("BCHRC8","CHR CHRIS II REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J D D,EOJ Q ; EOJ ; S BCHET=$H Q D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROCESS Q PROCESS ; S BCHPROG=$P(BCHR0,U,2) ;I BCHPRG,BCHPRG'=BCHPROG Q I BCHRPT="PR" S BCHITEM=$P(BCHR0,U,3) I BCHRPT="PG" S BCHITEM=BCHPROG S BCHDATE=$P(BCHR0,U) S Y=BCHDATE D DD^%DT S BCHMON=$P(Y," ")_$P(Y,",",2),X=BCHMON,%DT="" D ^%DT S BCHIDAT=Y S BCHTOT=$P(BCHR0,U,27)+$P(BCHR0,U,11),BCHS=$P(BCHR0,U,27),BCHT=$P(BCHR0,U,11) S $P(^(BCHMON),U)=$S($D(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON)):$P(^(BCHMON),U)+BCHTOT,1:BCHTOT) S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,2)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,2)+BCHS S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,3)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,3)+BCHT S $P(^("TOTAL"),U)=$S($D(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL")):$P(^("TOTAL"),U)+BCHTOT,1:BCHTOT) S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,2)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,2)+BCHS S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,3)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,3)+BCHT Q PG ; S BCHRN=8,BCHCH="PROGRAM" Q PR ; S BCHRN=8.2,BCHCH="PROVIDER" Q BCHRC8P BCHRC8P ; IHS/TUCSON/LAB - print all visit report ; [ 06/05/99 8:52 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y I '$D(^XTMP("BCHRC8",BCHJOB,BCHBTH)) S BCHNONE="",BCHPG=0 D HEAD W !!,"NO DATA TO REPORT",!! G DONE K BCHQUIT S BCHPG=0 S BCHBRK=0 ; PROG ; process for each program, monthly numbers S BCHPROG=0 F S BCHPROG=$O(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHPROG)) Q:BCHPROG'=+BCHPROG!($D(BCHQUIT)) D Q:BCHBRK . D @("HEAD"_(2-($E(IOST,1,2)="C-"))) . Q:$D(BCHQUIT) .S M="" F S M=$O(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHPROG,"MONTHS",M)) Q:M'=+M!($D(BCHQUIT)) D Q:BCHBRK .. I $Y>(IOSL-4) D EOP Q:BCHBRK ..; I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .. S R=$O(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHPROG,"MONTHS",M,"")) .. W !?3,R F I=1:1:3 S V=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHPROG,"MONTHS",M,R),U,I),V=V/60 W ?(I*20),$J($FN(V,",",0),10) .. Q . Q:BCHBRK . D:$O(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHPROG))'="" EOP . Q DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRC8",BCHJOB,BCHBTH),BCHJOB,BCHBTH Q HEAD ;I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF HEAD2 ; if printer S BCHPG=BCHPG+1 W !,$P(^VA(200,DUZ,0),U,2),?58,BCHDT,?72,"Page ",BCHPG,! W !?20,"********** CHR REPORT NO. ",BCHRN," **********" W !!?17,"HOURS (SERVICE+TRAVEL) BY MONTH AND ",BCHCH D @BCHRPT W !?17,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !,"MONTH/YEAR",?20,"TOTAL HOURS",?40,"SERVICE HOURS",?60,"TRAVEL HOURS" W !,$TR($J(" ",80)," ","-") Q PG ; Q:$D(BCHNONE) S BCHPROGN=$P(^BCHTPROG(BCHPROG,0),U)_" ("_$P(^(0),U,5)_")",X=$L(BCHPROGN)+10 W !!?((80-X)/2),"PROGRAM: ",BCHPROGN Q PR ; Q:$D(BCHNONE) S BCHNAME=$P(^VA(200,BCHPROG,0),U),X=$L(BCHNAME)+11 W !!?((80-X)/2),"PROVIDER: ",$P(^VA(200,BCHPROG,0),U) Q ; EOP ; pause OR form feed between pages of report for terminal/printer I $E(IOST,1,2)="P-"!($D(IO("S"))) W @IOF Q W ! S DIR(0)="EO" D ^DIR K DIR S:$D(DUOUT) (DIRUT,BCHBRK)=1 Q BCHRC9 BCHRC9 ; IHS/TUCSON/LAB - CHRIS II Report 2 ; [ 06/09/99 12:35 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**6,7**;OCT 28, 1996 ;IHS/CMI/LAB - PATCH 6 fixed logic on total services ; I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q S BCHJOB=$J,BCHBTH=$H D INFORM GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter BEGINNING Date of Service for Report" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G XIT S BCHBD=Y ED ;get ending date W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ENDING Date of Service for Report" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S BCHED=Y S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X ; ZIS ;CALL TO XBDBQUE S XBRP="^BCHRC9P",XBRC="PROC^BCHRC9",XBRX="XIT^BCHRC9",XBNS="BCH" D ^XBDBQUE D XIT Q ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q XIT ; K V,BCHSD,BCHBD,BCHBDD,BCHED,BCHEDD,BCHODAT,BCHR,BCHR0,X,P,S,N,BCHQUIT,BCHBTH,BCHDT,BCHNAME,BCHPRG,BCHBT,BCHJOB K X,Y Q ; INFORM ; W:$D(IOF) @IOF W !?20,"********** CHR REPORT NO. 9 **********" W !!?28,"DATA SUMMARY BY PROVIDER",!!,"You must enter the time frame for the report.",! Q ; ; PROC ;EP - PROCESS REFERRAL REPORT D XTMP^BCHUTIL("BCHRC9","CHR CHRIS II REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J S ^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL")=0 D D,EOJ Q ; EOJ ; S BCHET=$H Q D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROCESS Q PROCESS ; S C=$P(BCHR0,U,3),BCHNAME=$P(^VA(200,C,0),U) I '$D(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME)) S ^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME)=0 S (X,C)=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X S C=C+1 D .S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)+1,$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)+1 .S S=$P(^BCHRPROB(X,0),U,4),Y=$P(^BCHTSERV(S,0),U,3) .I Y="LT"!(Y="AM")!(Y="OT") D ..S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$P(^BCHRPROB(X,0),U,5),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$P(^BCHRPROB(X,0),U,5) ..;IHS/CMI/LAB - modified line below patch 6 ..I C=1 S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$P(BCHR0,U,11),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$P(BCHR0,U,11) .E D ..S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$P(^BCHRPROB(X,0),U,5),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(^BCHRPROB(X,0),U,5) ..;IHS/CMI/LAB - patch 6 modified line below ..I C=1 S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$P(BCHR0,U,11),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(BCHR0,U,11) .Q S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)+$P(BCHR0,U,12) S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)+$P(BCHR0,U,12) S N=$P(BCHR0,U,27)+$P(BCHR0,U,11) S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)+N,$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)+N Q BCHRC9P BCHRC9P ; IHS/TUCSON/LAB - = print all visit report ; [ 06/05/99 8:53 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 START ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y K BCHQUIT S BCHPG=0 S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y I '$D(^XTMP("BCHRC9",BCHJOB,BCHBTH)) W !!,"NO DATA TO REPORT",!! G DONE TOTAL ; D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ; I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE W !,"TOTAL" S J=25 F I=1,2 S X=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,I) W ?J,$J($FN(X,",",0),10) S J=J+11 F I=3:1:5 S X=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,I),X=X/60 W ?J,$J($FN(X,",",0),10) S J=J+11 W ! PROV ; S BCHPROV="" F S BCHPROV=$O(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHPROV)) Q:BCHPROV=""!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,BCHPROV S J=25 F I=1,2 S X=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHPROV),U,I) W ?J,$J($FN(X,",",0),10) S J=J+11 .F I=3:1:5 S X=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHPROV),U,I),X=X/60 W ?J,$J($FN(X,",",0),10) S J=J+11 .Q .Q DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRC9",BCHJOB,BCHBTH),BCHJOB,BCHBTH Q HEAD ; I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF HEAD2 ; if printer S BCHPG=BCHPG+1 W !,$P(^VA(200,DUZ,0),U,2),?58,BCHDT,?72,"Page ",BCHPG,! W !?20,"********** CHR REPORT NO. 9 **********" W !!?28,"DATA SUMMARY BY PROVIDER" W !?17,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !?25,"TOT NUM OF",?36," NUMBER",?47," S&T HRS",?58," S&T HRS",?69," S&T HRS" W !,"PROVIDER",?25,"ACTIVITIES",?36," SERVED",?47," ALL SRVS",?58," NON-ADM",?69," ADM SRV" W !,$TR($J(" ",80)," ","-") Q BCHRCH1 BCHRCH1 ; IHS/TUCSON/LAB - PROCESS REPORT ; [ 06/05/99 8:54 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; ; ; START ; D XTMP^BCHUTIL("BCHRCH","CHR CHRIS II REPORT") S BCHTT=0 S (BCHBT,BCHBTH)=$H,BCHJOB=$J D D D SETTMP D END Q ; D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; END ; S BCHET=$H D EOJ Q EOJ ; Q D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROC Q PROC ; S BCHPROG=$P(BCHR0,U,2) I BCHPRG,BCHPRG'=BCHPROG Q S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHC=BCHC+1 D .S P=$P(^BCHRPROB(BCHX,0),U),A=$P(^BCHRPROB(BCHX,0),U,4),S=$P(^BCHRPROB(BCHX,0),U,5) .S BCHTT=BCHTT+S I BCHC=1 S BCHTT=BCHTT+$P(BCHR0,U,11) .S ^(P)=$S($D(^XTMP("BCHRCH",BCHJOB,BCHBT,"PROBLEM",P)):^(P)+S,1:S) I BCHC=1 S ^(P)=^(P)+$P(BCHR0,U,11) .S ^(A)=$S($D(^XTMP("BCHRCH",BCHJOB,BCHBT,"ACTIVITY",A)):^(A)+S,1:S) I BCHC=1 S ^(A)=^(A)+$P(BCHR0,U,11) Q ; SETTMP ; S X=0 F S X=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"ACTIVITY",X)) Q:X'=+X S ^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP ACTS",9999999-^(X),X)=X_U_^(X)_U_(^(X)/BCHTT) S X=0 F S X=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"PROBLEM",X)) Q:X'=+X S ^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP PROBS",9999999-^(X),X)=X_U_^(X)_U_(^(X)/BCHTT) Q BCHRCHP BCHRCHP ; IHS/TUCSON/LAB - HIGHTLISTS Report ; [ 06/05/99 8:55 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; PRINT ;EP - PRINT TOP TEN RECORDS D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S BCHPG=0 I BCHTT=0 D HEAD W "NO DATA TO REPORT" G DONE S BCHTH=BCHTT/60 PROB ; S BCHPROC="P" D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ; S (BCHX,C)=0 F S BCHX=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP PROBS",BCHX)) Q:BCHX'=+BCHX!(C>BCHLNO)!($D(BCHQUIT)) D .S BCHY=0 F S BCHY=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP PROBS",BCHX,BCHY)) Q:BCHY'=+BCHY!($D(BCHQUIT)) S C=C+1 D ..S H=$P(^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP PROBS",BCHX,BCHY),U,2),P=$P(^(BCHY),U,3)*100,H=H/60 ..I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) ..I BCHCHRT="L" W !,$P(^BCHTPROB(BCHY,0),U),?36,$J($FN(H,",",1),10),?58,$J(P,5,1) Q ..I BCHCHRT="B" W !,$P(^BCHTPROB(BCHY,0),U),?23,$J($FN(H,",",0),6) D ... S Q=P+.5,Q=$P(Q,".") W ?32 F I=1:1:Q W "*" ...W " (",$J(P,5,1),"%)" ...Q ..Q .Q G:$D(BCHQUIT) DONE TOTALP ; I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE W !!,"ALL HEALTH PROBLEMS" I BCHCHRT="L" W ?36,$J($FN(BCHTH,",",1),10),?58,$J("100%",5) I BCHCHRT="B" W ?23,$J($FN(BCHTH,",",0),6) I $Y>(IOSL-5) D HEAD G:$D(BCHQUIT) DONE W !! ACT ; G:$D(BCHQUIT) DONE S BCHPROC="A" I $Y>(IOSL-20) D HEAD G:$D(BCHQUIT) DONE G ACT1 D @BCHCHRT ACT1 S (BCHX,C)=0 F S BCHX=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP ACTS",BCHX)) Q:BCHX'=+BCHX!(C>BCHLNO)!($D(BCHQUIT)) D .S BCHY=0 F S BCHY=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP ACTS",BCHX,BCHY)) Q:BCHY'=+BCHY!($D(BCHQUIT)) S C=C+1 D ..S H=$P(^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP ACTS",BCHX,BCHY),U,2),P=$P(^(BCHY),U,3)*100,H=H/60 ..I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) ..I BCHCHRT="L" W !,$P(^BCHTSERV(BCHY,0),U),?36,$J($FN(H,",",1),10),?58,$J(P,5,1) Q ..I BCHCHRT="B" W !,$P(^BCHTSERV(BCHY,0),U),?23,$J($FN(H,",",0),6) D ...S Q=P+.5,Q=$P(P,".") W ?32 F I=1:1:Q W "*" ...W " (",$J(P,5,1),"%)" ...Q ..Q .Q G:$D(BCHQUIT) DONE TOTALA ; I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE W !!,"ALL SERVICES" I BCHCHRT="L" W ?36,$J($FN(BCHTH,",",1),10),?58,$J("100%",5) I BCHCHRT="B" W ?23,$J($FN(BCHTH,",",0),6) I $Y>(IOSL-5) D HEAD G:$D(BCHQUIT) DONE W !! DONE D DONE^BCHUTIL1 K ^XTMP("BCHRCH",BCHJOB,BCHBT),BCHJOB,BCHBT Q HEAD ; ;I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I BCHY=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I BCHY=0!(Y=0)!($D(DUOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF ; HEAD2 ; if printer S BCHPG=BCHPG+1 W !,"DATE PRINTED: ",BCHDT,?$S(BCHCHRT="L":72,1:121),"Page ",BCHPG W ! W !,"COMMUNITY HEALTH REPRESENTATIVE REPORT 13 -- HIGHLIGHTS" W !,"TOP ",BCHLNO," HEALTH PROBLEMS AND SERVICES" W !,"REPORTING PERIOD: ",BCHBDD," TO ",BCHEDD,! I BCHCHRT="L" D L I BCHCHRT="B" D B Q L ; Q:$G(BCHPROC)="" W !,$S(BCHPROC="P":"HEALTH PROBLEM",1:"SERVICE"),?35,"SERVICE & TRAVEL",?58,"% OF TOTAL",!?40,"HOURS" W !,$TR($J(" ",80)," ","-") Q B ; Q:$G(BCHPROC)="" W !,$S(BCHPROC="P":"HEALTH PROBLEM",1:"SERVICE"),?23," S+T" S J=38 F I=10:10:100 W ?J,I,"%" S J=J+10 W !?23,"HOURS" S J=41 F I=1:1:10 W ?J,"|" S J=J+10 BCHRL1 BCHRL1 ; IHS/TUCSON/LAB - PROCESS CHR RECORD LIST ; [ 06/03/99 7:21 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; ; START ; D XTMP^BCHUTIL("BCHRL","CHR GENERAL RETRIEVAL") S (BCHBT,BCHBTH)=$H,BCHJOB=$J,BCHRCNT=0 S BCHPROC=BCHPTVS_BCHTYPE I $D(BCHRDTR),BCHPTVS="P" D VD,END Q D @BCHPROC,END Q ; VS ;run by search template S BCHR=0 F S BCHR=$O(^DIBT(BCHSEAT,1,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,9),'$P(^(0),U,11) S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,8) D PROC,EOJ Q VD ; Run by visit date S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D V1 Q ; PP ; S BCHR=0 F S BCHR=$O(^DPT(BCHR)) Q:BCHR'=+BCHR I '$P(^DPT(BCHR,0),U,19) S DFN=BCHR D PROC Q ; PS ; S BCHR=0 F S BCHR=$O(^DIBT(BCHSEAT,1,BCHR)) Q:BCHR'=+BCHR I $D(^DPT(BCHR,0)),'$P(^(0),U,19) S DFN=BCHR D PROC,EOJ Q ; ; END ; S BCHET=$H D EOJ Q EOJ ; Q V1 ; S BCHR="" F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,8) D PROC,EOJ Q PROC ; S BCHR11=$G(^BCHR(BCHR,11)),BCHR12=$G(^BCHR(BCHR,12)),BCHR13=$G(^BCHR(BCHR,13)) I BCHPTVS="P",DFN="" Q D SCREENS Q:$D(BCHSKIP) K BCHSRT,BCHPRNT S BCHCRIT=BCHSORT,BCHX=0 X:$D(^BCHSORT(BCHSORT,5)) ^BCHSORT(BCHSORT,5) I '$D(BCHPRNT) D . I BCHPTVS="V" S Y=$P($P(BCHR0,U),".") D DD^%DT S BCHPRNT=Y Q . S BCHPRNT=$P(^DPT(DFN,0),U) . Q S BCHSRT=BCHPRNT I BCHSRT="" S BCHSRT="??" I '$D(BCHRDTR) S ^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRT,BCHR)="",BCHRCNT=BCHRCNT+1 I $D(BCHRDTR) S ^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRT,DFN)="",BCHRCNT=BCHRCNT+1 Q:'$G(DFN) Q:$D(^XTMP("BCHRL",BCHJOB,BCHBTH,"PATIENTS",DFN)) S ^XTMP("BCHRL",BCHJOB,BCHBTH,"PATIENTS",DFN)="",BCHPTCT=BCHPTCT+1 Q SCREENS ; K BCHSKIP S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI!($D(BCHSKIP)) D .I '$P(^BCHSORT(BCHI,0),U,8) D SINGLE Q .D MULT .Q Q SINGLE ; K X,BCHSPEC S X="",BCHX=0 X:$D(^BCHSORT(BCHI,1)) ^(1) I X="" S BCHSKIP="" Q I '$D(BCHSPEC),'$D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X)) S BCHSKIP="" Q Q MULT ; K BCHFOUN,BCHSKIP,BCHSPEC,X S BCHX=0,X="" X:$D(^BCHSORT(BCHI,1)) ^(1) I $O(X(""))="" S BCHSKIP="" Q I '$D(BCHSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S BCHFOUN="" Q I $D(BCHSPEC),$D(X) S BCHFOUN=1 Q S:'$D(BCHFOUN) BCHSKIP="" Q XIT ;EP - CALLED FROM BCHRL K BCHBD,BCHBDD,BCHED,BCHEDD,BCHSD,BCHSORT,BCHSORV,BCHTCW,BCHRPT,BCHLHDR,BCHDISP,%H,BCHET,BCHLINE,BCHPRNM,BCHPRNT,BCHSKIP,BCHTYPE,BCHSPAG,BCHEN1,BCHSEAT,BCHPTVS,BCHPROC,BCH,BCHCAND,BCHHDR,BCHHEAD,BCHGDB,BCHGDE,BCHGDS K BCHACE,BCHCTYP,BCHFLG,BCHG,BCHNAME,BCHNIFN,BCHSAVE,BCHTITL,BCHQUIT,BCHPCNT,BCHQFLG,BCHPTCT,BCHTL,BCHXREF,BCHSRTR,BCHSRTV,BCHGBD,BCHGBE,BCHGBS K C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH XIT1 ;EP K BCHANS,BCHBTH,BCHC,BCHCNT,BCHCRIT,BCHCUT,BCHD,BCHDISP,BCHDONE,BCHHIGH,BCHI,BCHJOB,BCHQMAN,BCHSEL,BCHTEXT,BCHRAR,BCHSKIP,BCHPRNT,BCHPRNM,BCHLINE,BCHRCNT,BCHDFET,BCHY,DFN K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BCHPACK,BCHEP1,BCHEP2,D,BCHLENG,BCHLHDR,BCHSAVE Q BCHRLP BCHRLP ; IHS/TUCSON/LAB - PRINT CHR RECORD REPORT ; [ 06/03/99 7:22 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**5,7**;OCT 28, 1996 ; ;IHS/CMI/LAB - tmp to xtmp ;CMI/TUCSON/LAB - modified 2 lines to replace a reference to the 8th piece to a reference to 4th piece 6/22/98 patch 5 START ;EP - Set up header line, dash line S X=0,BCHHEAD="" F S X=$O(^BCHTRPT(BCHRPT,12,X)) Q:X'=+X S BCHHDR=$P(^BCHSORT($P(^BCHTRPT(BCHRPT,12,X,0),U),0),U,6),BCHLENG=$P(^BCHTRPT(BCHRPT,12,X,0),U,2),BCHHDR=$E(BCHHDR,1,BCHLENG) D .S J=$L(BCHHDR),BCHHEAD=BCHHEAD_BCHHDR,K=$P(^BCHTRPT(BCHRPT,12,X,0),U,2)+1 F I=J:1:K S BCHHEAD=BCHHEAD_" " .Q S BCHDASH="",$P(BCHDASH,"-",BCHTCW)="-" D COVPAGE^BCHRLP1 ;print cover page - note: if user ^'s out of cover page, processing continues PROC ;process printing of report I BCHCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done S BCHPG=0 I '$D(^XTMP("BCHRL",BCHJOB,BCHBTH)) G DONE S (BCHSRTV,BCHFRST)="" K BCHQUIT F S BCHSRTV=$O(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV)) Q:BCHSRTV=""!($D(BCHQUIT)) D V G:$D(BCHQUIT) DONE I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE I $D(BCHRCNT),BCHPTVS="V" W !!!,"Total ",$S(BCHPTVS="P":"Patients",1:"Records"),": ",BCHRCNT ;W !!,"Total Patients: ",BCHPTCT DONE ; D DONE^BCHUTIL1 Q V ;GETS DATA HITS S BCHSCNT=0 ;get readable sort value S BCHSRTR="",BCHR=$O(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV,"")) I BCHR]"" S BCHCRIT=BCHSORT D .I BCHPTVS="V" S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) X:$D(^BCHSORT(BCHSORT,3)) ^(3) S BCHSRTR=BCHPRNT ;CMI/TUCSON/LAB - changed ,U,8 to ,U,4 PATCH 5 6/22/98 .I BCHPTVS="P" S DFN=BCHR X:$D(^BCHSORT(BCHSORT,3)) ^(3) S BCHSRTR=BCHPRNT I $G(BCHSPAG)!($D(BCHFRST)) D HEAD Q:$D(BCHQUIT) K BCHFRST S BCHR=0 F S BCHR=$O(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV,BCHR)) Q:BCHR'=+BCHR!($D(BCHQUIT)) D .I BCHPTVS="V" S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) D PRINT Q ;CMI/TUCSON/LAB - changed 8 to 4 patch 5 6/22/98 .S DFN=BCHR D PRINT .Q Q:$D(BCHQUIT) I $Y>(IOSL-3) D HEAD Q:$D(BCHQUIT) W:$G(BCHSPAG) !!,"SUB-TOTAL for ",BCHSORV," ",BCHSRTR,": ",BCHSCNT W:BCHCTYP="S" !?10,$E(BCHSRTR,1,30),?45,$J(BCHSCNT,8) Q PRINT ; S BCHSCNT=BCHSCNT+1 Q:BCHCTYP="S" K ^XTMP("BCHLINE",$J) S ^XTMP("BCHLINE",$J,1)="" I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,12,BCHI)) Q:BCHI'=+BCHI!($D(BCHQUIT)) S BCHCRIT=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U) D .I '$P(^BCHSORT(BCHCRIT,0),U,8) D SINGLE Q .D MULT .Q S BCHX=0 F S BCHX=$O(^XTMP("BCHLINE",$J,BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,^XTMP("BCHLINE",$J,BCHX) Q SINGLE ;process single valued item K BCHPRNT S BCHX=0 X:$D(^BCHSORT(BCHCRIT,3)) ^(3) I $G(BCHPRNT)="" S BCHPRNT="--" S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E($G(BCHPRNT),1,BCHLENG) D .S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_" " .S X=1 F S X=$O(^XTMP("BCHLINE",$J,X)) Q:X'=+X I $L(^XTMP("BCHLINE",$J,X))<$L(^XTMP("BCHLINE",$J,1)) S K=$L(^XTMP("BCHLINE",$J,X))+1,J=$L(^XTMP("BCHLINE",$J,1)) F I=K:1:J S ^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_" " Q MULT ; K BCHPRNT,BCHPRNM S (BCHX,BCHPCNT)=0 X:$D(^BCHSORT(BCHCRIT,3)) ^(3) I '$D(BCHPRNM) S BCHPRNT="--" D .S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNT,1,BCHLENG) D ..S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_" " S X=0 F S X=$O(BCHPRNM(X)) Q:X'=+X D .I X=1 D Q ..S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNM(1),1,BCHLENG) D ...S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_" " .S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNM(X),1,BCHLENG) D ..I '$D(^XTMP("BCHLINE",$J,X)) S ^XTMP("BCHLINE",$J,X)="",K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1,$P(^XTMP("BCHLINE",$J,X)," ",($L(^XTMP("BCHLINE",$J,1))-K))="" ..S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_" " S X=1 F S X=$O(^XTMP("BCHLINE",$J,X)) Q:X'=+X I $L(^XTMP("BCHLINE",$J,X))<$L(^XTMP("BCHLINE",$J,1)) S K=$L(^XTMP("BCHLINE",$J,X))+1,J=$L(^XTMP("BCHLINE",$J,1)) F I=K:1:J S ^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_" " Q DIQ ; K BCHPRNT,BCHFILE,BCHFIEL S BCHFILE=$P($P(^BCHSORT(BCHCRIT,0),U,4),","),BCHFIEL=$P($P(^(0),U,4),",",2) S DIQ(0)="EN",DIQ="BCHPRNT(",DIC=BCHFILE,DR=BCHFIEL D EN^DIQ1 K DIC,DR,DIQ I '$D(BCHPRNT(BCHFILE,DA,BCHFIEL,"E")) S BCHPRNT(BCHFILE,DA,BCHFIEL,"E")="--" S BCHPRNT=BCHPRNT(BCHFILE,DA,BCHFIEL,"E") Q HEAD ;ENTRY POINT D HEAD^BCHRLP2 Q BCHRLP1 BCHRLP1 ; IHS/TUCSON/LAB - CONT OF BCHRLP ; [ 06/03/99 7:23 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; COVPAGE ;EP ;W:$D(IOF) @IOF W:IOST["C-" @IOF W !?5,"RPMS/CHR-PCC ",$S(BCHPTVS="P":"PATIENT",1:"CHR RECORD")," ",$S(BCHCTYP="D":"LISTING",1:"COUNT") W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U) W !!,"The following report contains a ",$S(BCHPTVS="V":"CHR Record",1:"Patient")," report based on the",!,"following criteria:",! SHOW ; W !,$S(BCHPTVS="P":"PATIENT",1:"VISIT")," Selection Criteria" I $D(BCHRDTR),$D(BCHBDD) W !!?6,"Date of Service range: ",BCHBDD," to ",BCHEDD,! W:BCHTYPE="D" !!?6,"Date of Service range: ",BCHBDD," to ",BCHEDD,! W:BCHTYPE="S" !!?6,"Search Template: ",$P(^DIBT(BCHSEAT,0),U),! I '$D(^BCHTRPT(BCHRPT,11)) G SHOWP S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI D .I $Y>(IOSL-5) D PAUSE^BCHRL01 W @IOF .W !?6,$P(^BCHSORT(BCHI,0),U),": " .S BCHY=0,C=0 K BCHQ F S BCHY=$O(^BCHTRPT(BCHRPT,11,BCHI,11,"B",BCHY)) S C=C+1 Q:BCHY=""!($D(BCHQ)) W:C'=1&(BCHY'="") " ; " S X=BCHY X:$D(^BCHSORT(BCHI,2)) ^(2) W X K BCHQ SHOWP ; I BCHCTYP="T" D COUNT Q I BCHCTYP="S" D I 1 .I $Y>(IOSL-6) D PAUSE^BCHRL01 W @IOF .W !!,"Report will contain sub-totals by ",$P(^BCHSORT(BCHSORT,0),U),"." .I '$D(^XTMP("BCHRL",BCHJOB,BCHBTH)) W !!,$S(BCHPTVS="V":"NO VISITS",1:"NO PATIENTS")_" TO REPORT.",! D PAUSE^BCHRL01 W:$D(IOF) @IOF .Q I BCHCTYP'="D" D PAUSE^BCHRL01 W:$D(IOF) @IOF Q I $Y>(IOSL-4) D PAUSE^BCHRL01 W @IOF W !!,"PRINT Field Selection" I '$D(^BCHTRPT(BCHRPT,12)) G PAUSE S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,12,BCHI)) Q:BCHI'=+BCHI S BCHCRIT=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U) D .I $Y>(IOSL-4) D PAUSE^BCHRL01 W:$D(IOF) @IOF .W !?6,$P(^BCHSORT(BCHCRIT,0),U)," (" S X=$O(^BCHTRPT(BCHRPT,12,"B",BCHCRIT,"")) W $P(^BCHTRPT(BCHRPT,12,X,0),U,2),")" I $Y>(IOSL-4) D PAUSE^BCHRL01 W:$D(IOF) @IOF W !?10," TOTAL column width: ",BCHTCW Q:'$G(BCHSORT) I $Y>(IOSL-4) D PAUSE^BCHRL01 W:$D(IOF) @IOF W !!?6,$S(BCHPTVS="V":"Records",1:"Patients")," will be sorted by: ",$P(^BCHSORT(BCHSORT,0),U),! I $Y>(IOSL-4) D PAUSE^BCHRL01 W:$D(IOF) @IOF I $G(BCHSPAG) W !?6,"Each ",$P(^BCHSORT(BCHSORT,0),U)," will be on a separate page.",! I '$D(^XTMP("BCHRL",BCHJOB,BCHBTH)) W !!,$S(BCHPTVS="V":"NO VISITS",1:"NO PATIENTS")_" TO REPORT.",! Q PAUSE ; D PAUSE^BCHRL01 W:IOST["C-" @IOF ;D PAUSE^BCHRL01 W:$D(IOF) @IOF Q COUNT ;if COUNTING entries only I $Y>(IOSL-5) D PAUSE^BCHRL01 W:$D(IOF) @IOF I '$D(^XTMP("BCHRL",BCHJOB,BCHBTH)) W !!!,$S(BCHPTVS="V":"NO VISITS",1:"NO PATIENTS")_" TO REPORT.",! I $D(BCHRCNT),BCHPTVS="V" W !!!,"Total COUNT of ",$S(BCHPTVS="P":"Patients",1:"Records"),": ",BCHRCNT I $D(BCHPTCT),BCHPTVS="P" W !!!,"Total COUNT of ",$S(BCHPTVS="P":"Patients",1:"Records"),": ",BCHPTCT Q WP ;EP - Entry point to print wp fields pass node in BCHNODE ;PASS FILE IN BCHFILE, ENTRY IN BCHDA K ^UTILITY($J,"W") S BCHG=^DIC(BCHFILE,"GL",0),BCHG=BCHG_BCHDA_",BCHX)" S DIWL=1,DIWR=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2) F S BCHX=$O(@BCHG) Q:BCHX'=+BCHX D .S Y=BCHG_",0)" S X=@Y D ^DIWP .Q S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=^UTILITY($J,"W",DIWL,Z,0) K DIWL,DIWR,DIWF,Z K ^UTILITY($J,"W"),BCHNODE,BCHFILE,BCHDA Q BCHRLP2 BCHRLP2 ; IHS/TUCSON/LAB - PRINT GEN RET ; [ 06/03/99 7:24 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; DONE ;EP D DONE^BCHUTIL1,XIT^BCHRPTU K ^XTMP("BCHRL",BCHJOB,BCHBT) D DEL^BCHRL K BCHBD,BCHSD,BCHED,BCHEDD,BCHBDD,BCHRPT,BCHHEAD,BCHLINE,BCHL,BCHRCNT,BCHI,BCHCRIT,BCHR,BCHRREC,BCHJOB,BCHBT,BCHBTH,BCHQUIT,BCHHDR,BCHDASH,BCHLENG,BCHPCNT,BCHTCW,BCHODAT,BCHPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPNSEX K BCHSORT,BCHSRT,BCHSORX,BCHFILE,BCHFIEL,BCHPRNT,BCHX,BCHTYPE,BCHFOUN,D0,J,K,L,BCHPRNM,BCHTEST,BCHSEAT,BCHLHDR,BCHFRST Q HEAD ;ENTRY POINT I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ;EP W:$D(IOF) @IOF S BCHPG=BCHPG+1 W ?16,"********** CONFIDENTIAL PATIENT INFORMATION **********" I $G(BCHTITL)="" S BCHTEXT="CHR "_$S(BCHPTVS="V":"ENCOUNTER",1:"PATIENT")_" LISTING",BCHLENG=$L(BCHTEXT) W !?((BCHTCW-BCHLENG)/2),BCHTEXT,?(BCHTCW-8),"Page ",BCHPG I $G(BCHTITL)]"" S BCHLENG=$L(BCHTITL) W !?((BCHTCW-BCHLENG)/2),BCHTITL,?(BCHTCW-8),"Page ",BCHPG I BCHTYPE="D" S BCHLENG=46 S:BCHTCWD .I $P(^AUPNMCR(P,11,BCHMIFN,0),U,2)]"",$P(^(0),U,2)D ..I $P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]"",$P(^(0),U,2)D .I $P(^AUPNPRVT(P,11,BCHMIFN,0),U,7)]"",$P(^(0),U,7)D .I $P(^AUPNMCR(P,11,BCHMIFN,0),U,2)]"",$P(^(0),U,2)D ..I $P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]"",$P(^(0),U,2)") ..S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ..Q .Q ; MCDX ; Q ; PI ; NEW BCHMIFN,BCHFLG I '$D(^DPT(P,0)) G PIX I $P(^DPT(P,0),U,19) G PIX I '$D(^AUPNPAT(P,0)) G PIX I '$D(^AUPNPRVT(P,11)) G PIX I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)D .I $P(^AUPNPRVT(P,11,BCHMIFN,0),U,7)]"",$P(^(0),U,7)(IOSL-6) D HEADER G:$D(BCHQUIT) DONE DONE ; D DONE^BCHUTIL1,XIT^BCHRPTU K ^XTMP("BCHRPT",BCHJOB,BCHBT) K BCHBT,BCHBTH,BCHJOB,BCHET Q PRINT1 ; ;get readable sort variable S BCHSRTR="",BCHR=$O(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT,"")) I BCHR]"" S BCHCRIT=BCHSORT D .S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) X:$D(^BCHSORT(BCHSORT,3)) ^BCHSORT(BCHSORT,3) .Q S (BCHSCNT,BCHR)=0 I $G(BCHSPAG)!($D(BCHFRST)) D HEADER Q:$D(BCHQUIT) K BCHFRST F S BCHR=$O(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT,BCHR)) Q:BCHR=""!($D(BCHQUIT)) S BCHR0=^BCHR(BCHR,0) D @("PRINT"_BCHRTYPE) I $Y>(IOSL-3) D HEADER Q:$D(BCHQUIT) W:$G(BCHSPAG) !!!,"SUB-TOTAL for ",BCHSORV," ",BCHRSRT,": ",BCHSCNT Q PRINTB ; S:$G(BCHSPAG) BCHSCNT=BCHSCNT+1 I $Y>(IOSL-6) D HEADER Q:$D(BCHQUIT) S BCHRCNT=BCHRCNT+1 W !,$E($P(BCHR0,U),4,5),"/",$E($P(BCHR0,U),6,7),"/",$E($P(BCHR0,U),2,3) S X=$P(BCHR0,U,2) I X]"" W ?10,$P(^BCHTPROG(X,0),U,5) W ?18,$$PPINI^BCHUTIL(BCHR) W ?22,$S($P(BCHR0,U,4)]"":$E($P(^DPT($P(BCHR0,U,4),0),U),1,20),$G(^BCHR(BCHR,11))]"":$E($P(^BCHR(BCHR,11),U),1,20),1:" ") S BCHACTL=$P(BCHR0,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,7) S BCHSFAC=$P(BCHR0,U,5) I BCHSFAC]"" S BCHSFAC=$E($P(^AUTTLOC(BCHSFAC,0),U,2),1,7) I BCHSFAC="" S BCHSFAC=BCHACTL W ?43,$E(BCHSFAC,U,10) I '$D(^BCHRPROB("AD",BCHR)) W ?51," --" E S BCHP=0,BCHC=0 F S BCHP=$O(^BCHRPROB("AD",BCHR,BCHP)) Q:BCHP'=+BCHP S BCHPREC=^BCHRPROB(BCHP,0) D GETPROB W:BCHC ! W ?51,BCHX S BCHC=BCHC+1 Q ; PRINTD ;detailed print S:$G(BCHSPAG) BCHSCNT=BCHSCNT+1 I $Y>(IOSL-6) D HEADER Q:$D(BCHQUIT) S BCHRCNT=BCHRCNT+1 W !,$E($P(BCHR0,U),4,5),"/",$E($P(BCHR0,U),6,7),"/",$E($P(BCHR0,U),2,3) S X=$P(BCHR0,U,2) I X]"" W ?10,$P(^BCHTPROG(X,0),U,5) W ?18,$$PPINI^BCHUTIL(BCHR) W ?22,$S($P(BCHR0,U,4)]"":$E($P(^DPT($P(BCHR0,U,4),0),U),1,20),$G(^BCHR(BCHR,11))]"":$E($P(^BCHR(BCHR,11),U),1,20),1:" ") S BCHACTL=$P(BCHR0,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,7) S BCHSFAC=$P(BCHR0,U,5) I BCHSFAC]"" S BCHSFAC=$E($P(^AUTTLOC(BCHSFAC,0),U,2),1,7) I BCHSFAC="" S BCHSFAC=BCHACTL W ?43,$E(BCHSFAC,U,10) I '$D(^BCHRPROB("AD",BCHR)) W ?51," --" E S BCHP=0,BCHC=0 F S BCHP=$O(^BCHRPROB("AD",BCHR,BCHP)) Q:BCHP'=+BCHP S BCHPREC=^BCHRPROB(BCHP,0) D GETPROB W:BCHC ! W ?51,BCHX S BCHC=BCHC+1 S X=$P(BCHR0,U,7) I X]"" W ?86,$E($P(^BCHTREF(X,0),U),1,7) S X=$P(BCHR0,U,8) I X]"" W ?96,$E($P(^BCHTREF(X,0),U),1,7) W ?105,$P(BCHR0,U,9) W ?110,$P(BCHR0,U,11) W ?116,$P(BCHR0,U,12) ; Q GETPROB ; S BCHX="" S X=$P(^BCHTPROB($P(BCHPREC,U),0),U,2)_" " S X=X_$S($P(BCHPREC,U,4)]"":$P(^BCHTSERV($P(BCHPREC,U,4),0),U,3),1:" ")_" " S X=X_$J($P(BCHPREC,U,5),3)_" " S X=X_$S($P(BCHPREC,U,6)]"":$E($P(^AUTNPOV($P(BCHPREC,U,6),0),U),1,19),1:" ") S BCHX=BCHX_X Q HEADER ; D HEADER^BCHRP11 Q BCHRP21 BCHRP21 ; IHS/TUCSON/LAB - PROCESS REPORT ; [ 06/03/99 7:47 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB tmp to xtmp ; ; ; ; START ; D XTMP^BCHUTIL("BCHRP2","CHR ACTIVITY REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J D D,END Q ; D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; END ; S BCHET=$H D EOJ Q EOJ ; Q D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROC Q PROC ; S BCHPROG=$P(BCHR0,U,2),BCHPROGN=$P(^BCHTPROG(BCHPROG,0),U)_" ("_$P(^(0),U,5)_")" S BCHLOC=$P(BCHR0,U,6) Q:BCHLOC="" S BCHLOCN=$P(^BCHTACTL(BCHLOC,0),U) S BCHPROV=$P(BCHR0,U,3) Q:BCHPROV="" S BCHPNAME=$P(^VA(200,BCHPROV,0),U) S BCHX=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHACT=$P(^BCHRPROB(BCHX,0),U,4) I BCHACT]"" S BCHACTN=$P(^BCHTSERV(BCHACT,0),U)_" ("_$P(^(0),U,3)_")" D .S $P(^(BCHACTN),U)=$S($D(^XTMP("BCHRP2",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN)):$P(^(BCHACTN),U)+1,1:1) .S $P(^XTMP("BCHRP2",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN),U,2)=$P(^XTMP("BCHRP2",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN),U,2)+$P(^BCHRPROB(BCHX,0),U,5) Q BCHRP2P BCHRP2P ; IHS/TUCSON/LAB - print all visit report ; [ 06/03/99 7:48 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S (BCHATOT,BCHFTOT,BCHPTOT,BCHPG)=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) K BCHQUIT PROG ; S BCHPROG="" F S BCHPROG=$O(^XTMP("BCHRP2",BCHJOB,BCHBTH,"RECORDS",BCHPROG)) Q:BCHPROG=""!($D(BCHQUIT)) D .S (BCHATOT("R"),BCHATOT("AT"),BCHATOT("P"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,"PROGRAM: ",BCHPROG .D LOC .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?50,"=======",?60,"=======",! .W "PROGRAM TOTAL:",?50,$J(BCHATOT("R"),7),?60,$J(BCHATOT("AT"),7),! DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRP2",BCHJOB,BCHBTH),BCHJOB,BCHBTH Q LOC ; S BCHLOC="" F S BCHLOC=$O(^XTMP("BCHRP2",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC)) Q:BCHLOC=""!($D(BCHQUIT)) D .S (BCHLTOT("R"),BCHLTOT("AT"),BCHLTOT("P"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !?10,"ACTIVITY LOCATION: ",BCHLOC .D PROV .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?50,"=======",?60,"=======",! .W ?10,"ACTIVITY LOCATION TOTAL:",?50,$J(BCHLTOT("R"),7),?60,$J(BCHLTOT("AT"),7),! Q PROV ; S BCHPROV="" F S BCHPROV=$O(^XTMP("BCHRP2",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC,BCHPROV)) Q:BCHPROV=""!($D(BCHQUIT)) D .S (BCHPTOT("R"),BCHPTOT("AT"),BCHPTOT("P"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !?15,"PROVIDER: ",BCHPROV .D ACT .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?50,"=======",?60,"=======",! .W ?15,"PROVIDER TOTAL:",?50,$J(BCHPTOT("R"),7),?60,$J(BCHPTOT("AT"),7),! Q ACT ; S BCHACT="" F S BCHACT=$O(^XTMP("BCHRP2",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC,BCHPROV,BCHACT)) Q:BCHACT=""!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .S BCHREC=$P(^XTMP("BCHRP2",BCHJOB,BCHBT,"RECORDS",BCHPROG,BCHLOC,BCHPROV,BCHACT),U),BCHAT=$P(^(BCHACT),U,2),BCHPAT=$P(^(BCHACT),U,3) .W !?20,$E(BCHACT,1,29),?50,$J(BCHREC,7),?60,$J(BCHAT,7) .S BCHATOT("R")=BCHATOT("R")+BCHREC,BCHLTOT("R")=BCHLTOT("R")+BCHREC,BCHPTOT("R")=BCHPTOT("R")+BCHREC .S BCHATOT("AT")=BCHATOT("AT")+BCHAT,BCHLTOT("AT")=BCHLTOT("AT")+BCHAT,BCHPTOT("AT")=BCHPTOT("AT")+BCHAT .S BCHATOT("P")=BCHATOT("P")+BCHPAT,BCHLTOT("P")=BCHLTOT("P")+BCHPAT,BCHPTOT("P")=BCHPTOT("P")+BCHPAT Q HEAD ;I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF HEAD2 ; if printer S BCHPG=BCHPG+1 W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********" W !?28,"CHR/PCC ACTIVITY REPORT" W !,$P(^VA(200,DUZ,0),U,2),?58,BCHDT,?72,"Page ",BCHPG,! W ?17,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !?50,"# RECS",?60,"ACT TIME" W !,$TR($J(" ",80)," ","-") Q BCHRP31 BCHRP31 ; IHS/TUCSON/LAB - PROCESS REPORT ; [ 06/03/99 7:49 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; ; ; START ; D XTMP^BCHUTIL("BCHRP3","CHR ACTIVITY REPORT") S (BCHBT,BCHBTH)=$H,BCHJOB=$J D D,END Q ; D ; Run by date of service S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1 Q ; END ; S BCHET=$H D EOJ Q EOJ ; Q D1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"",$D(^BCHRPROB("AD",BCHR)) S BCHR0=^BCHR(BCHR,0) D PROC Q PROC ; S BCHPROG=$P(BCHR0,U,2),BCHPROGN=$P(^BCHTPROG(BCHPROG,0),U)_" ("_$P(^(0),U,5)_")" S BCHLOC=$P(BCHR0,U,6) Q:BCHLOC="" S BCHLOCN=$P(^BCHTACTL(BCHLOC,0),U) S BCHPROV=$P(BCHR0,U,3) Q:BCHPROV="" S BCHPNAME=$P(^VA(200,BCHPROV,0),U) S BCHX=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHACT=$P(^BCHRPROB(BCHX,0),U,4),BCHPROB=$P(^(0),U) I BCHACT]"" D .S BCHACTN=$P(^BCHTSERV(BCHACT,0),U)_" ("_$P(^(0),U,3)_")" .S BCHPROB=$P(^BCHTPROB(BCHPROB,0),U)_" ("_$P(^(0),U,2)_")" .S $P(^(BCHPROB),U)=$S($D(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB)):$P(^(BCHPROB),U)+1,1:1) .S $P(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB),U,2)=$P(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB),U,2)+$P(BCHR0,U,27) Q BCHRP3P BCHRP3P ; IHS/TUCSON/LAB - print all visit report ; [ 06/03/99 7:50 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp START ; D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y S (BCHATOT,BCHACTOT,BCHSTOT,BCHFTOT,BCHPTOT,BCHPG)=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) K BCHQUIT PROG ; S BCHPROG="" F S BCHPROG=$O(^XTMP("BCHRP3",BCHJOB,BCHBTH,"RECORDS",BCHPROG)) Q:BCHPROG=""!($D(BCHQUIT)) D .S (BCHATOT("R"),BCHATOT("AT"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,"PROGRAM: ",BCHPROG .D LOC .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?59,"=======",?67,"=======",! .W "PROGRAM TOTAL:",?59,$J(BCHATOT("R"),7),?67,$J(BCHATOT("AT"),7),! DONE ; D DONE^BCHUTIL1 K ^XTMP("BCHRP3",BCHJOB,BCHBTH) Q LOC ; S BCHLOC="" F S BCHLOC=$O(^XTMP("BCHRP3",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC)) Q:BCHLOC=""!($D(BCHQUIT)) D .S (BCHLTOT("R"),BCHLTOT("AT"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !?4,"ACTIVITY LOCATION: ",BCHLOC .D PROV .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?59,"=======",?67,"=======",! .W ?4,"ACTIVITY LOCATION TOTAL:",?59,$J(BCHLTOT("R"),7),?67,$J(BCHLTOT("AT"),7),! Q PROV ; S BCHPROV="" F S BCHPROV=$O(^XTMP("BCHRP3",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC,BCHPROV)) Q:BCHPROV=""!($D(BCHQUIT)) D .S (BCHPTOT("R"),BCHPTOT("AT"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !?11,"CHR: ",BCHPROV .D ACT .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?59,"=======",?67,"=======",! .W ?11,"PROVIDER TOTAL:",?59,$J(BCHPTOT("R"),7),?67,$J(BCHPTOT("AT"),7),! Q ACT ; S BCHACT="" F S BCHACT=$O(^XTMP("BCHRP3",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC,BCHPROV,BCHACT)) Q:BCHACT=""!($D(BCHQUIT)) D .S (BCHACTOT("R"),BCHACTOT("AT"))=0 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !?17,"ACTIVITY: ",$E(BCHACT,1,28) .D PROB .Q:$D(BCHQUIT) .I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT) .W !?59,"=======",?67,"=======",! .W ?17,"ACTIVITY TOTAL:",?59,$J(BCHACTOT("R"),7),?67,$J(BCHACTOT("AT"),7),! Q PROB ; S BCHPROB="" F S BCHPROB=$O(^XTMP("BCHRP3",BCHJOB,BCHBTH,"RECORDS",BCHPROG,BCHLOC,BCHPROV,BCHACT,BCHPROB)) Q:BCHPROB=""!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .S BCHREC=$P(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROG,BCHLOC,BCHPROV,BCHACT,BCHPROB),U),BCHAT=$P(^(BCHPROB),U,2),BCHPAT=$P(^(BCHPROB),U,3) .W !?22,"PROBLEM:",?32,$E(BCHPROB,1,30),?59,$J(BCHREC,7),?67,$J(BCHAT,7) .S BCHATOT("R")=BCHATOT("R")+BCHREC,BCHLTOT("R")=BCHLTOT("R")+BCHREC,BCHPTOT("R")=BCHPTOT("R")+BCHREC,BCHACTOT("R")=BCHACTOT("R")+BCHREC .S BCHATOT("AT")=BCHATOT("AT")+BCHAT,BCHLTOT("AT")=BCHLTOT("AT")+BCHAT,BCHPTOT("AT")=BCHPTOT("AT")+BCHAT,BCHACTOT("AT")=BCHACTOT("AT")+BCHAT Q HEAD ;I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; if terminal W:$D(IOF) @IOF HEAD2 ; if printer S BCHPG=BCHPG+1 W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********" W !,$P(^VA(200,DUZ,0),U,2),?33,BCHDT,?70,"Page ",BCHPG,! W ?24,"ACTIVITY REPORT BY HEALTH PROBLEM",! W ?17,"REPORT DATES: ",BCHBDD," TO ",BCHEDD,! W !?59,"# RECS",?67,"ACT TIME",! W !,$TR($J(" ",80)," ","-") Q BCHRPT4 BCHRPT4 ; IHS/TUCSON/LAB - PROCESS VISIT LIST ; [ 06/05/99 8:31 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; ; ; START ; D XTMP^BCHUTIL("BCHRPT","CHR RECORD LIST") D XTMP^BCHUTIL("BCHRAP2","CHR REPORT") D XTMP^BCHUTIL("BCHTEN","CHR TOP TEN DX") S (BCHBT,BCHBTH)=$H,BCHJOB=$J I $P(^BCHRCNT(BCHRPTC,0),U,11)]"" S BCHRPREP=$P(^(0),U,11) S BCHRPREP=$TR(BCHRPREP,"~","^") D @BCHRPREP D D,END Q ; S ;run by search template S BCHR=0 F S BCHR=$O(^DIBT(BCHSEAT,1,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,9),'$P(^(0),U,11) D PROC,EOJ Q D ; Run by visit date S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D V1 Q ; END ; I $P(^BCHRCNT(BCHRPTC,0),U,9)]"" S BCHRPOSP=$P(^(0),U,9) S BCHRPOSP=$TR(BCHRPOSP,"~","^") D @BCHRPOSP S BCHET=$H D EOJ Q EOJ ; K BCHB,BCHI,BCHR,BCHRCNT Q V1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0),DFN=$P(BCHR0,U,4) D PROC Q PROC ; S BCHR11=$G(^BCHR(BCHR,11)),BCHR12=$G(^BCHR(BCHR,12)),BCHR13=$G(^BCHR(BCHR,13)) D SCREENS Q:$D(BCHSKIP) K BCHSRT,BCHPRNT S BCHCRIT=BCHSORT,BCHX=0 X:$D(^BCHSORT(BCHSORT,5)) ^BCHSORT(BCHSORT,5) I $G(BCHPRNT)']"" D . I BCHPTVS="V" S Y=$P($P(BCHR0,U),".") S BCHPRNT=Y Q . S BCHPRNT=$S($G(DFN):$P(^DPT(DFN,0),U),1:$P($G(^BCHR(BCHR,11)),U)) .Q S BCHSRT=BCHPRNT I BCHSRT="" S BCHSRT="NONE AVAILABLE" I $G(BCHRPTST)]"" D @(BCHRPTST) Q S ^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHSRT,BCHR)="" Q SCREENS ; S DFN=$P(BCHR0,U,4) K BCHSKIP S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI!($D(BCHSKIP)) D .I '$P(^BCHSORT(BCHI,0),U,8) D SINGLE Q .D MULT .Q Q SINGLE ; S X="" X:$D(^BCHSORT(BCHI,1)) ^(1) I X="" S BCHSKIP="" Q I '$D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X)) S BCHSKIP="" Q Q MULT ; K BCHFOUN,BCHSKIP,X S BCHX=0,X="" X:$D(^BCHSORT(BCHI,1)) ^(1) I '$L($O(X)) S BCHSKIP="" Q S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S BCHFOUN="" Q S:'$D(BCHFOUN) BCHSKIP="" Q BCHRPTCP BCHRPTCP ; IHS/TUCSON/LAB - generic report cover page ; [ 06/05/99 9:06 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; COVPAGE ;EP ;W:$D(IOF) @IOF W:IOST["C-" @IOF W !!!?31,"CHR RECORD LISTING" W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U) W !!,"The following visit listing contains CHR records selected based on the",!,"following criteria:",! SHOW ; W !?28,"RECORD SELECTION CRITERIA" W !!,"Date of Service range: ",BCHBDD," to ",BCHEDD,! I '$D(^BCHTRPT(BCHRPT,11)) G SHOWP S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI D .I $Y>(IOSL-4) D PAUSE^BCHRPTU W @IOF .W !,$P(^BCHSORT(BCHI,0),U),": " .K BCHQ S Y=0,C=0 F S Y=$O(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S C=C+1 Q:Y=""!($D(BCHQ)) W:C'=1 " ; " S X=Y X:$D(^BCHSORT(BCHI,2)) ^(2) W X SHOWP ; I $Y>(IOSL-4) D PAUSE^BCHRPTU W @IOF I $D(BCHRPTC) W !!,"Report Type: ",$P(^BCHRCNT(BCHRPTC,0),U,6) ;I $D(BCHRPTC) W !!,"Report Type: ",$S(BCHRTYPE["D":"DETAILED RECORD LIST",BCHRTYPE["B":"STANDARD BRIEF",1:"??") I '$D(^BCHTRPT(BCHRPT,12)) G PAUSE W !!?29,"PRINT FIELD SELECTION",! S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,12,BCHI)) Q:BCHI'=+BCHI S BCHCRIT=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U) D .I $Y>(IOSL-4) D PAUSE^BCHRPTU W:$D(IOF) @IOF .W !,$P(^BCHSORT(BCHCRIT,0),U)," (" S X=$O(^BCHTRPT(BCHRPT,12,"B",BCHCRIT,"")) W $P(^BCHTRPT(BCHRPT,12,X,0),U,2),")" W !," TOTAL column width: ",BCHTCW I $Y>(IOSL-5) D PAUSE^BCHRPTU W:$D(IOF) @IOF SORT ; I $G(BCHSORT)]"" W !!,"Records will be sorted by: ",$P(^BCHSORT(BCHSORT,0),U),! I $G(BCHSPAG) W !,"Each ",$P(^BCHSORT(BCHSORT,0),U)," will be on a separate page.",! I $Y>(IOSL-4) D PAUSE^BCHRPTU W:$D(IOF) @IOF I '$D(^XTMP("BCHRPT",BCHJOB,BCHBTH)) W !!,"NO RECORDS TO DISPLAY.",! PAUSE D PAUSE^BCHRPTU Q BCHRPTST BCHRPTST ; IHS/TUCSON/LAB - PROCESS REPORT ; [ 06/05/99 8:22 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp ; SETTMP2 ;EP ; set tmp for top ten record reports UTL ; I BCHRPROC="ACT"!(BCHRPROC="ACTC")!(BCHRPROC="PROB")!(BCHRPROC="PROBCAT") D MULT10 Q D @BCHRPROC S X=BCHA S BCHPOV=@BCHSORT I '$D(@X) S @X=0 S %=+(@X),%=%+1,%1=$P((@X),U,3),%1=%1+$P(BCHR0,U,27),@X=%_"^"_BCHSRT2_"^"_%1 Q ; SET F BCHPOV=0:0 S BCHPOV=$O(@BCHA) Q:'BCHPOV S %=^(BCHPOV),@BCHC@(9999999-%,BCHPOV)="" ;global reference in BCHA is ^XTMP("BCHTEN",BCHJOB,BCHBT,"POV",BCHPOV) Q SETTMP ;EP - CALLED FROM BCHPT4 I BCHRPROC="ACT"!(BCHRPROC="ACTC")!(BCHRPROC="PROB")!(BCHRPROC="PROBCAT") D MULT Q D @BCHRPROC S ^(BCHSRT2)=$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TOTAL",@BCHSORT,BCHSRT2)):^(BCHSRT2)+1,1:1) S ^(BCHSRT2)=$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"PATIENT",@BCHSORT,BCHSRT2)):^(BCHSRT2)+$P(BCHR0,U,12),1:$P(BCHR0,U,12)) S ^(BCHSRT2)=$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TIME TOTAL",@BCHSORT,BCHSRT2)):^(BCHSRT2)+$P(BCHR0,U,27),1:$P(BCHR0,U,27)) Q PROG ; S BCHPROG=$P(BCHR0,U,2) I BCHPROG="" S BCHPROG="NO PROGRAM ENTERED",BCHSRT2="--" Q S BCHSRT2=$P(^BCHTPROG(BCHPROG,0),U,5),BCHPROG=$P(^BCHTPROG(BCHPROG,0),U) Q ; DATE ; S BCHDATE=$P(BCHODAT,".") S X=BCHDATE D H^%DTC S BCHSRT2=$P("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1) I BCHSRT2="" S BCHSRT2="UNKNOWN" Q PROV ; S BCHPROV=$$PPNAME^BCHUTIL(BCHR),BCHSRT2=$E($$PPCLS^BCHUTIL(BCHR,"E"),1,20) Q COMM ; S BCHCOMM=$P($G(^BCHR(BCHR,11)),U,6) I BCHCOMM="" S BCHCOMM="NOT AVAILABLE",BCHSRT2="-------" Q S BCHSRT2=$P(^AUTTCOM(BCHCOMM,0),U,8),BCHCOMM=$P(^(0),U) Q ACT ; S BCHACT=$P(^BCHRPROB(BCHPPOV,0),U,4),BCHSRT2=$P(^BCHTSERV(BCHACT,0),U,3),BCHACT=$P(^BCHTSERV(BCHACT,0),U) Q SU ; S BCHSU=$P(^AUTTLOC($P(BCHR0,U,4),0),U,5) I BCHSU="" S BCHSU="NONE ENTERED",BCHSRT2="9999" Q S BCHSRT2=$P(^AUTTSU(BCHSU,0),U,4),BCHSU=$P(^AUTTSU(BCHSU,0),U) LOS ; S BCHVLOC=$P(BCHR0,U,6) I BCHVLOC="" S BCHSRT2="--",BCHVLOC="NONE ENTERED" Q S BCHSRT2=$P(^BCHTACTL(BCHVLOC,0),U,5),BCHVLOC=$P(^(0),U) Q ; PROB ; S BCHPROB=$P(^BCHRPROB(BCHPPOV,0),U),BCHSRT2=$P(^BCHTPROB(BCHPROB,0),U,2),BCHPROB=$P(^BCHTPROB(BCHPROB,0),U) Q PROBCAT ; S BCHSRT2=$P(^BCHTPROB($P(^BCHRPROB(BCHPPOV,0),U),0),U,3),(BCHSRT2,BCHPROB)=$P(^BCHTHAC(BCHSRT2,0),U) Q MULT ; S BCHPPOV=$O(^BCHRPROB("AD",BCHR,"")) I BCHPPOV="" S BCHPROB="NO POVS ENTERED",BCHSRT2="-----" Q S BCHPPOV=0 F S BCHPPOV=$O(^BCHRPROB("AD",BCHR,BCHPPOV)) Q:BCHPPOV'=+BCHPPOV D .D @BCHRPROC .S ^(BCHSRT2)=$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TOTAL",@BCHSORT,BCHSRT2)):^(BCHSRT2)+1,1:1) .S ^(BCHSRT2)=$S($D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"PATIENT",@BCHSORT,BCHSRT2)):^(BCHSRT2)+$P(BCHR0,U,12),1:$P(BCHR0,U,12)) .I $D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TIME TOTAL",@BCHSORT,BCHSRT2)) S ^(BCHSRT2)=^(BCHSRT2)+$P(^BCHRPROB(BCHPPOV,0),U,5) .I '$D(^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TIME TOTAL",@BCHSORT,BCHSRT2)) S ^XTMP("BCHRAP2",BCHJOB,BCHBTH,"TIME TOTAL",@BCHSORT,BCHSRT2)=$P(^BCHRPROB(BCHPPOV,0),U,5) Q MULT10 ; S BCHPPOV=$O(^BCHRPROB("AD",BCHR,"")) I BCHPPOV="" S (BCHPROB,BCHACT)="NO POVS ENTERED",BCHSRT2="-----" Q S BCHPPOV=0 F S BCHPPOV=$O(^BCHRPROB("AD",BCHR,BCHPPOV)) Q:BCHPPOV'=+BCHPPOV D .D @BCHRPROC .S X=BCHA .S BCHPOV=@BCHSORT .I '$D(@X) S @X=0 .S %=+(@X),%=%+1,%1=$P((@X),U,3),%1=%1+$P(^BCHRPROB(BCHPPOV,0),U,5),@X=%_"^"_BCHSRT2_"^"_%1 .Q Q BCHRTEN BCHRTEN ; IHS/TUCSON/LAB - TOP TEN POVS ; [ 06/05/99 8:29 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ;IHS/CMI/LAB - tmp to xtmp PREPROC ; S %="^XTMP(""BCHTEN"",BCHJOB,BCHBT,",BCHA=%_"""POV"",BCHPOV)",BCHC=%_"1)",E=%_"2)",F=%_"3)",G=%_"4)",BCHTOT=0,BCHVTOT=0 Q POSTPROC ; D SET Q ; ; SET ; S BCHPOV="" F S BCHPOV=$O(@BCHA) Q:BCHPOV="" S %=^(BCHPOV),@BCHC@(9999999-%,BCHPOV)="" ;BCHA,BCHC global references are set in PREPROC+1 S1 S (X,I)=0 F S X=$O(@BCHC@(X)) Q:'X F Y=0:0 S Y=$O(@BCHC@(X,Y)) Q:'Y S I=I+1,@F@(I)=Y I I=BCHLNO G S2 S2 S (X,I)=0 F S X=$O(@E@(X)) Q:'X F Y=0:0 S Y=$O(@E@(X,Y)) Q:'Y S I=I+1,@G@(I)=Y I I=BCHLNO G S3 S3 Q ; ; ; PRNTPRE ;EP PRIM ; S BCHPRIM="" I $E(BCHRRPT)="A" G CHRT S DIR(0)="S^P:PRIMARY POV Only;S:PRIMARY and SECONDARY POV's",DIR("A")="Include which POV's",DIR("B")="P" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) S BCHQUIT=1 Q S BCHPRIM=Y CHRT ;EP S DIR(0)="S^L:List of items with Counts;B:Bar Chart (132 col)",DIR("A")="Select Type of Report",DIR("B")="L" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G PRIM S BCHCHRT=Y NUM ;get # entries S DIR(0)="NO^5:"_$S(BCHCHRT="B":35,1:100)_":0",DIR("A")="How many entries do you want in the "_$S(BCHCHRT="B":"bar chart",1:"list"),DIR("B")="10",DIR("?")="" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR I $D(DIRUT) G CHRT S BCHLNO=Y I $D(DTOUT)!(Y=-1) G NUM Q ; PRINT ;EP;PRINT TOP TEN RECORDS D NOW^%DTC S Y=X D DD^%DT S BCHDT=Y S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y D COVPAGE^BCHRPTCP S BCHPG=0 D HEAD S %="^XTMP(""BCHTEN"",BCHJOB,BCHBT,",A=%_"""POV"",BCHPOV)",B=%_"""APC"",BCHAPC)",BCHC=%_"1)",E=%_"2)",F=%_"3)",G=%_"4)" S (J,I)=0 F S I=$O(^XTMP("BCHTEN",BCHJOB,BCHBT,1,I)) Q:I'=+I!($D(BCHQUIT))!(J>(BCHLNO-1)) D .S BCHPOV="" F S BCHPOV=$O(^XTMP("BCHTEN",BCHJOB,BCHBT,1,I,BCHPOV)) Q:BCHPOV=""!($D(BCHQUIT)) S J=J+1 D ..I J=1,BCHCHRT="B" D SETDASH ..I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) ..I BCHCHRT="L" W !,J,".",?6,$E(BCHPOV,1,30),?39,$E($P(@BCHA,U,2),1,15),?56,+(@BCHA),?66,$P(@BCHA,U,3) Q ..W !,$E(BCHPOV,1,17),?18," (",$E($P(@BCHA,U,2),1,6),")",?27,"|" S L=+(@BCHA),D=L\BCHDASH F %=1:1:D W "*" ..W " ",+(@BCHA) I BCHCHRT="B",$G(BCHDASH) D .W ! S J=27 F X=1:1:10 W ?J,"|_________" S J=J+10 .W "|",! .S J=27 F X=0:1:10 W ?J,BCHDASH*10*X S J=J+10 PEXIT D DONE^BCHUTIL1 Q SETDASH ;set dash limits for bar chart NEW L,D S L=+(@BCHA) S M=$L(L),F=$E(L)+1,L=F F %=1:1:(M-1) S L=L_"0" I L<100 S L=100 S BCHDASH=L\100 Q HEAD I 'BCHPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q HEAD1 ; W:$D(IOF) @IOF S BCHPG=BCHPG+1 W !?2,BCHDT,?72,"Page ",BCHPG S BCHLENG=$L($P(^DIC(4,DUZ(2),0),U)) W !?((80-BCHLENG)/2),$P(^DIC(4,DUZ(2),0),U) W ! W !,"TOP ",BCHLNO," ",BCHINF,"'s." I $E(BCHRRPT)="P" W !,$S(BCHPRIM="P":"PRIMARY POV Only",1:"Both PRIMARY and SECONDARY POV's are included.") W !,"DATES: ",BCHBDD," TO ",BCHEDD,! I BCHCHRT="L" W !,"No.",?6,BCHHD1,?39,BCHHD2,?56,"# RECS",?65,"ACT TIME (MINS)" I BCHCHRT="B" W !,BCHHD1 I BCHCHRT="L" W !,$TR($J(" ",80)," ","-") I BCHCHRT="B" W !,$TR($J(" ",132)," ","-") Q BCHUEDT BCHUEDT ; IHS/TUCSON/LAB - EDIT A CHR RECORD ; [ 09/21/98 9:49 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**6**;OCT 28, 1996 ;IHS/CMI/LAB - patch 6 9/21/98 added ability to enter a ;registered patient on editing a record ; ; ;edit a chr record, called from protocol ; EN ;EP D EN^VALM2(XQORNOD(0),"OS") I '$D(VALMY) W !,"No records selected." G XIT S BCHR=$O(VALMY(0)) I 'BCHR K BCHR,VALMY,XQORNOD W !,"No record selected." G XIT S BCHR=BCHVRECS("IDX",BCHR,BCHR) I 'BCHR K BCHRDEL,BCHR D PAUSE^BCHUTIL1 D XIT Q I '$D(^BCHR(BCHR,0)) W !,"Not a valid CHR RECORD." K BCHRDEL,BCHR D PAUSE^BCHUTIL1 D XIT Q D FULL^VALM1 DISP ;EP D EN^BCHUDSP S BCHR0=^BCHR(BCHR,0) S DFN=$P(BCHR0,U,4) S BCHTYPE="" F D TYPE Q:BCHTYPE="" D RECCHECK^BCHUADD1 I $D(BCHERROR) W !!,$C(7),$C(7),"PLEASE RE-EDIT THE RECORD AND CORRECT THIS ERROR!!!",! H 5 D XIT Q TYPE ; get type of data to edit S BCHTYPE="" W !! S DIR(0)="SO^1:Patient Demographic Data;2:All Other Record Data",DIR("A")="EDIT Which Data Item" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) Q:Y="" S BCHTYPE=+Y D @BCHTYPE Q XIT ;eof I '$G(BCHR) G REF ;do event protocol call S BCHEV("TYPE")="E" ;set up bchev with all pcc ptrs ;wipe out pcc ptrs in chr record S BCHEV("VFILES",9000010)=$P(^BCHR(BCHR,0),U,15) S X=0 F S X=$O(^BCHR(BCHR,31,X)) Q:X'=+X S F=$P(^BCHR(BCHR,31,X,0),U),N=$P(^(0),U,2) I F,N S BCHEV("VFILES",F,N)="" K ^BCHR(BCHR,31) D PROTOCOL^BCHUADD1 REF ; I $G(BCHEN1) G EOJ S VALMBCK="R" D TERM^VALM0 D GATHER^BCHUARL S VALMCNT=BCHRCNT D HDR^BCHUAR EOJ K BCHR,BCHTYPE,BCHR0,BCHERROR,BCHC,BCHRPOV,DFN,BCHX K BCHTYPE Q ; 1 ;PATIENT demographic ;WILL be different depending if patient pointer or other data I $P(^BCHR(BCHR,0),U,4)]"" D Q .W !,"This is a REGISTERED Patient. You cannot edit any of ",$S($P(^DPT($P(^BCHR(BCHR,0),U,4),0),U,2)="M":"his",1:"her")," demographic data.",!,"You may enter a different patient if this was entered in error.",! .S BCHODFN=DFN,DIE="^BCHR(",DA=BCHR,DR=".04" D ^DIE K DIE,DA,DR .S DFN=$P(^BCHR(BCHR,0),U,4) .Q:DFN=BCHODFN .;backfill pt ptr in CHR POV .S BCHX=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D ..S DIE="^BCHRPROB(",DA=BCHX,DR=".02////"_DFN,DITC="" ..D ^DIE ..K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC ..I $D(Y) W !,"error updating pov's with patient, NOTIFY PROGRAMMER" H 5 ..Q .Q ;IHS/CMI/LAB - PATCH 6 ADDED THESE LINES TO ALLOW ENTRY OF A ;REGISTERED PATIENT ON EDIT W !!,"If this is a registered patient, enter their name or chart number",!,"otherwise press enter to update a non-registered patient's data.",!! ;IHS/CMI/LAB added patch 6 S DIE="^BCHR(",DA=BCHR,DR=".04" D ^DIE K DIE,DA,DR ;IHS/CMI/LAB added patch 6 I $P(^BCHR(BCHR,0),U,4) Q ;IHS/CMI/LAB added patch 6 S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS K DR,DA,DDSFILE,DIC,DIE I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q Q 2 ;OTHER record data W ! S DA=BCHR,DDSFILE=90002,DR="[BCH EDIT RECORD DATA]" D ^DDS K DR,DA,DDSFILE,DIC,DIE I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q Q DISPPOVS ; W ! S (X,BCHC)=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X S BCHC=BCHC+1,BCHRPOV(BCHC)=X D .W !?2,BCHC,") ",$E($P(^BCHTPROB($P(^BCHRPROB(X,0),U),0),U),1,20),?29,$E($P(^BCHTSERV($P(^BCHRPROB(X,0),U,4),0),U),1,20),?52,$P(^BCHRPROB(X,0),U,5),?57,$P(^AUTNPOV($P(^BCHRPROB(X,0),U,6),0),U,1,21) .Q Q EPOV ;edit an existing pov D DISPPOVS W ! S DIR(0)="N^1:"_BCHC_":",DIR("A")="Which One do you wish to EDIT" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) Q Q:'Y I '$D(BCHRPOV(BCHC)) W !!,"Invalid choice." Q S DA=BCHRPOV(Y),DIE="^BCHRPROB(",DR="[BCH EDIT POV]" D ^DIE K DIE,DA,DIU,DIV,DIY,DIW,DR I $D(Y) W !!,"ERROR ENCOUNTERED IN EDITING A POV" Q Q APOV ;add a new pov W !!,"Adding a NEW POV...",! S DIE="^BCHR(",DR="[BCH ADD POV]",DA=BCHR D ^DIE K DIE,DA,DR,DIU,DIV,DIY,DIW I $D(Y) W !!,"NO POV ADDED!" Q DPOV ;delete pov D DISPPOVS S DIR(0)="N^1:"_BCHC_":",DIR("A")="Which One do you wish to DELETE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) Q Q:'Y I '$D(BCHRPOV(BCHC)) W !!,"Invalid choice." Q ; S DIR(0)="Y",DIR("A")="Are you sure you want to delete this POV",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) I 'Y W !,"Okay, not deleted." Q S DA=BCHRPOV(Y),DIK="^BCHRPROB(" D ^DIK W !,"POV DELETED" K DA,DIK Q Q BCHUFP BCHUFP ; IHS/TUCSON/LAB - PRINT ENCOUNTER RECORD ; [ 06/03/97 12:35 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - added a few variables to kill in XIT+1 ; ;print individual forms for each member of group START ; I '$D(IOF) D HOME^%ZIS W @(IOF),!! W "********** ENCOUNTER FORM PRINT **********",!! W "This report will produce hard copy computed generated encounter forms.",! GETDATES ; BD ;get beginning date W !,"Please enter the date range for which forms should be printed.",! W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G XIT S BCHBD=Y ED ;get ending date W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ending Date" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S BCHED=Y S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y ; PAT ;one or all patients G PROV S BCHPAT="" S DIR(0)="Y",DIR("A")="Do you wish to print forms for one particular PATIENT",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 G:$D(DIRUT) GETDATES G:'Y PROV I Y=1 S DIC("A")="Enter PATIENT Name: ",DIC=9000001,DIC(0)="AEQMZ" D ^DIC G PAT:Y<0 S BCHPAT=+Y PROV ;limit by provider S BCHPROV="" S DIR(0)="Y",DIR("A")="Do you wish to print forms for one particular CHR",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 G:$D(DIRUT) GETDATES G:'Y ZIS I Y=1 S DIC("A")="Enter CHR Name: ",DIC=200,DIC(0)="AEQMZ" D ^DIC G PROV:Y<0 S BCHPROV=+Y ZIS ; S XBRC="COMP^BCHUFP",XBRP="PRINT^BCHUFP",XBNS="BCH",XBRX="XIT^BCHUFP" D ^XBDBQUE ; XIT ; K BCHR11,BCHR12,BCHRC,BCHRX,BCHRCNT,BCHRNODE,BCHRRPNM,BCHPREC,BCHR13,BCHW,BCHWP,BCHIOM ;IHS/TUCSON/LAB - patch 2 K ZTSK,Y,BCHBD,BCHED,IO("Q"),BCH80D,BCHBTH,BCHHRCN,BCHJOB,BCHLENG,BCHPCNT,BCHPG,BCHPROV,BCHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,BCHC,DIW,DIWI,DIWT,DIWTC,DIWX,DN K BCHPRNM,BCHPRNT,BCHPROB,BCHPRV,BCHR,BCHRCNT,BCHRLOC,BCHSD,BCHTOT,BCHBDD,BCHBT,BCHEDD,BCHEDO,BCHBDO,BCHBT,BCHFOUND,BCHHIT,BCHID,BCHLINE,BCHP,BCHHRN,BCHODAT,BCHQUIT,BCHR0,BCHTICL,BCHTNRQ,BCHTQ,BCHTTXT Q COMP ;EP - do nothing Q PRINT ; EP - print individual forms S BCHQUIT=0 D ; Run by visit date S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED)!(BCHQUIT) D V1 Q V1 ; S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR!(BCHQUIT) I $D(^BCHR(BCHR,0)) D I F D PRINT1^BCHUFPP .;CHECK PROVIDER .S F=0 .I 'BCHPROV S F=1 Q .I BCHPROV=$P(^BCHR(BCHR,0),U,3) S F=1 Q DEMO ;EP I $Y>(IOSL-9) D FF^BCHUFPP Q:BCHQUIT S BCHR11=$G(^BCHR(BCHR,11)) S DFN=$P(BCHR0,U,4) S BCHHRN=$S(DFN]"":$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:$P(BCHR11,U,11)) S:BCHHRN="" BCHHRN="" W !!?3,"HR#: ",BCHHRN,?35,"SEX: ",$S(DFN]"":$$EXTSET^XBFUNC(2,.02,$P(^DPT(DFN,0),U,2)),1:$P(BCHR11,U,3)) W !?3,"NAME: ",$S(DFN]"":$P(^DPT(DFN,0),U),1:$P(BCHR11,U)) W ?35,"Tribe: " I DFN]"",$P($G(^AUPNPAT(DFN,11)),U,8) W $P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U) E I $P(BCHR11,U,5) W $P(^AUTTTRI($P(BCHR11,U,5),0),U) W !?3,"SSN: ",$S(DFN]"":$P(^DPT(DFN,0),U,9),1:$P(BCHR11,U,4)) W ?35,"RESIDENCE: " I DFN]"" W $P($G(^AUPNPAT(DFN,11)),U,18) E W $P(BCHR11,U,7) W !?3,"DOB: " I DFN]"" S Y=$P(^DPT(DFN,0),U,3) I Y]"" D DD^%DT W Y I '$G(DFN) S Y=$P(BCHR11,U,2) I Y]"" D DD^%DT W Y W ?35,"FACILITY: " I $P(BCHR11,U,9)]"" W $P(^DIC(4,$P(BCHR11,U,9),0),U) W !?3,"PURPOSE OF REFERRAL: ",$P($G(^BCHR(BCHR,21)),U) W !?3,"INSURER: ",$P($G(^BCHR(BCHR,41)),U) W !!?35,"CHR SIGNATURE: _____________________________",! W !,$TR($J("",80)," ","*") D FF^BCHUFPP Q BCHUFPP BCHUFPP ; IHS/TUCSON/LAB - PRINT CHR FORMS ; [ 06/03/97 12:35 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**2**;OCT 28, 1996 ; ;IHS/TUCSON/LAB - patch 1 06/03/97 - modified so subj/obj data ;would display. ; PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY S BCHR0=^BCHR(BCHR,0) S BCHQUIT=0 I $E(IOST)="C" W:$D(IOF) @IOF W !!!?13,"********** CONFIDENTIAL PATIENT INFORMATION **********" W !?34,"CHR PCC FORM" W !?18,"*** Computer Generated Encounter Record ***" W !,$TR($J("",80)," ","*") I $Y>(IOSL-6) D FF Q:BCHQUIT W !?3,"Date of Service: " S Y=$P($P(BCHR0,U),".") D DD^%DT W Y W !?3,"Temporary Residence: ",$P($G(^BCHR(BCHR,11)),U,8),!?35,"Program Code: ",$P(^BCHTPROG($P(BCHR0,U,2),0),U,5) W !?35,"Provider (CHR): ",$$PPNAME^BCHUTIL(BCHR) W !,$TR($J("",80)," ","_") SUB ; ;IHS/TUCSON/LAB - modified to display subjective info patch 1 06/03/97 S BCHR12=$G(^BCHR(BCHR,12)) S BCHR13=$G(^BCHR(BCHR,13)) I $Y>(IOSL-5) D FF Q:BCHQUIT W !?3,"SUBJECTIVE INFORMATION (includes patient's complaint)",?65,"BP ",$P(BCHR12,U) S BCHDA=BCHR,BCHFILE=90002,BCHNODE=51,BCHIOM=58 D WP ;W !?65,"WT ",$P(BCHR12,U,2) ;W !?65,"HT ",$P(BCHR12,U,3) S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="WT "_$P(BCHR12,U,2) S BCHWP(2)=$G(BCHWP(2)),$E(BCHWP(2),62)="HT "_$P(BCHR12,U,3) S X=0 F S X=$O(BCHWP(X)) Q:X'=+X!(BCHQUIT) D .I $Y>(IOSL-4) D FF Q:BCHQUIT .W !?4,BCHWP(X) .Q I $Y>(IOSL-7) D FF Q:BCHQUIT OBJ ; ;IHS/TUCSON/LAB - modified to display objective info patch 1 06/03/97 W !,$TR($J("",80)," ","_") W !?3,"OBJECTIVE DATA",?30,"Temp ",$P(BCHR12,U,7)," Pulse ",$P(BCHR12,U,8)," Resp ",$P(BCHR12,U,9),?65,"HC ",$P(BCHR12,U,4) S BCHDA=BCHR,BCHFILE=90002,BCHNODE=61,BCHIOM=58 D WP ;W !?65,"VU ",$P(BCHR12,U,5) ;W !?65,"VC ",$P(BCHR12,U,6) S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="VU "_$P(BCHR12,U,5) S BCHWP(2)=$G(BCHWP(2)),$E(BCHWP(2),62)="VC "_$P(BCHR12,U,6) S X=0 F S X=$O(BCHWP(X)) Q:X'=+X!(BCHQUIT) D .I $Y>(IOSL-4) D FF Q:BCHQUIT .W !?4,BCHWP(X) .Q W !,$TR($J("",80)," ","_") POV ; I $Y>(IOSL-6) D FF Q:BCHQUIT W !?3,"ASSESSMENT - PCC Purpose of Visit" W !?3,"Hlth Prob",?13,"Svc",?18,"Svc",?30,"Narrative",?60,"Sub" W !?5,"Code",?13,"Code",?18,"Mins",?60,"Rel",?65,"Tests" W !,$TR($J("",80)," ","_") S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT) S BCHC=BCHC+1 D .I $Y>(IOSL-5) D FF Q:BCHQUIT .S BCHRNODE=^BCHRPROB(BCHX,0) .W !?6,$P(^BCHTPROB($P(BCHRNODE,U),0),U,2) .W ?14,$S($P(BCHRNODE,U,4)]"":$P(^BCHTSERV($P(BCHRNODE,U,4),0),U,3),1:"??") .W ?19,$P(^BCHRPROB(BCHX,0),U,5) .S BCHTNRQ=$P(^BCHRPROB(BCHX,0),U,6) S BCHTNRQ=$S(BCHTNRQ]"":$P(^AUTNPOV(BCHTNRQ,0),U),1:"<>") S BCHW=35 D WRT ;IHS/TUCSON/LAB - patch 2 .W ?23,BCHRPRNM(1),?61,$P(BCHRNODE,U,7) W:BCHC=1 ?65,"PPD ",$P(BCHR12,U,10) .W ! W:$D(BCHRPRNM(2)) ?23,BCHRPRNM(2) W:BCHC=1 ?65,"BS ",$S($P(BCHR13,U,2)]"":$P(BCHR13,U,2),$P(BCHR13,U)]"":$E($P(BCHR13,U),4,5)_"/"_$E($P(BCHR13,U),6,7)_"/"_$E($P(BCHR13,U),2,3),1:"") .W ! W:$D(BCHRPRNM(3)) ?23,BCHRPRNM(3) W:BCHC=1 ?65,"T/C ",$S($P(BCHR13,U,4)]"":$P(BCHR13,U,4),$P(BCHR13,U,3)]"":$E($P(BCHR13,U,3),4,5)_"/"_$E($P(BCHR13,U,3),6,7)_"/"_$E($P(BCHR13,U,3),2,3),1:"") .Q S X=3 F S X=$O(BCHRPRNM(X)) Q:X'=+X!(BCHQUIT) D:$Y>(IOSL-4) FF Q:BCHQUIT W !?23,BCHRPRNM(X) K BCHRPRNM Q:BCHQUIT PLANS ; ;IHS/TUCSON/LAB - modified to display plan info patch 1 06/03/97 I $Y>(IOSL-7) D FF Q:BCHQUIT W !,$TR($J("",80)," ","_") W !?3,"Plans/Treatments/Education/Medications" W ?65,"HCT ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_$E($P(BCHR13,U,7),2,3),1:"") S BCHDA=BCHR,BCHFILE=90002,BCHNODE=71,BCHIOM=52 D WP ;W !?65,"UA ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_$E($P(BCHR13,U,7),2,3),1:"") S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="UA "_$S($P(BCHR13,U,6)]"":$P(BCHR13,U,6),$P(BCHR13,U,5)]"":$E($P(BCHR13,U,5),4,5)_"/"_$E($P(BCHR13,U,5),6,7)_"/"_$E($P(BCHR13,U,5),2,3),1:"") S BCHWP(2)=$G(BCHWP(2)),$E(BCHWP(2),55)="Reproductive Factors" S BCHWP(3)=$G(BCHWP(3)),$E(BCHWP(3),55)="LMP " S:$P(BCHR0,U,13)]"" BCHWP(3)=BCHWP(3)_$E($P(BCHR0,U,13),4,5)_"/"_$E($P(BCHR0,U,13),6,7)_"/"_$E($P(BCHR0,U,13),2,3) S BCHWP(4)=$G(BCHWP(4)),$E(BCHWP(4),55)="FP "_$S($P(BCHR0,U,14)]"":$P(^BCHTFPM($P(BCHR0,U,14),0),U),1:"") S X=0 F S X=$O(BCHWP(X)) Q:X'=+X!(BCHQUIT) D .I $Y>(IOSL-4) D FF Q:BCHQUIT .W !?4,BCHWP(X) .Q W !,$TR($J("",80)," ","_") ACT ; I $Y>(IOSL-5) D FF Q:BCHQUIT W !?3,"Activity Location: ",$S($P(BCHR0,U,6)]"":$P(^BCHTACTL($P(BCHR0,U,6),0),U),1:"") I $P(BCHR0,U,5)]"" W ?40,"Hospital/Clinic: ",$E($P(^DIC(4,$P(BCHR0,U,5),0),U),1,22) W !?3,"Referred to CHR by: ",$S($P(BCHR0,U,7)]"":$E($P(^BCHTREF($P(BCHR0,U,7),0),U),1,15),1:""),?45,"Referred by CHR to: ",$S($P(BCHR0,U,8)]"":$E($P(^BCHTREF($P(BCHR0,U,8),0),U),1,15),1:"") W !?3,"Evaluation: ",$S($P(BCHR0,U,9)]"":$$EXTSET^XBFUNC(90002,.09,$P(BCHR0,U,9)),1:"") W !?3,"Travel Time: ",$P(BCHR0,U,11),?45,"Number Served: ",$P(BCHR0,U,12) W !,$TR($J("",80)," ","_") DEMO ;demographics D DEMO^BCHUFP Q WRT ;EP - Entry point to print wp fields pass node in BCHNODE K ^UTILITY($J,"W"),BCHRPRNM S BCHPCNT=0 S DIWL=1,DIWR=35,X=BCHTNRQ D ^DIWP S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S BCHPCNT=BCHPCNT+1,BCHRPRNM(BCHPCNT)=^UTILITY($J,"W",DIWL,Z,0) K DIWL,DIWR,DIWF,Z K ^UTILITY($J,"W"),BCHNODE,BCHFILE,BCHDA Q FF ;EP I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT=1 Q W:$D(IOF) @IOF Q WP ;EP - Entry point to print wp fields pass node in BCHWP ;PASS FILE IN BCHFILE, ENTRY IN BCHDA NEW G,P,BCHX K BCHWP K ^UTILITY($J,"W") S BCHX=0,P=0 S G=$S($G(G)]"":G,1:^DIC(BCHFILE,0,"GL")),G=G_BCHDA_","_BCHNODE_",BCHX)" S DIWR=$S($G(BCHIOM):BCHIOM,1:IOM),DIWL=0 F S BCHX=$O(@G) Q:BCHX'=+BCHX D .S Y=$P(G,")")_",0)" .S X="" I $G(BCHCAP)]"",BCHX=1 S X=BCHCAP .S X=X_@Y D ^DIWP .Q WPS ;EP S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S P=P+1,BCHWP(P)=^UTILITY($J,"W",DIWL,Z,0) K DIWL,DIWR,DIWF,Z K ^UTILITY($J,"W"),BCHNODE,BCHFILE,BCHDA,G,BCHCOL,BCHCAP Q BCHUTIL BCHUTIL ; IHS/TUCSON/LAB - UTILITIES ; [ 06/03/99 6:52 PM ] ;;1.0;IHS RPMS CHR SYSTEM;**7**;OCT 28, 1996 ; ;IHS/CMI/LAB - for xtmp 0 node set XTMP(N,T) ;EP I $G(N)="" Q S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_U_DT_U_T Q PPINI(REC) ;EP Retrieve CHR Primary Provider Initials NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHINI S BCHY=$P(^BCHR(REC,0),U,3) I 'BCHY S BCHINI="???" Q BCHINI S DA=BCHY,DIC=200,DR=1,DIQ="BCHINI",DIQ(0)="I" D EN^DIQ1 S BCHINI=$G(BCHINI(200,BCHY,1,"I")) S:BCHINI="" BCHINI="???" Q BCHINI PPNAME(REC) ;EP NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHNAME S BCHY=$P(^BCHR(REC,0),U,3) I '$D(BCHY) S BCHNAME="???" Q BCHNAME S BCHNAME=$P(^VA(200,BCHY,0),U) S:BCHNAME="" BCHNAME="???" Q BCHNAME PPINT(REC) ;primary provider internal # from 200 (duz) NEW X,Y,BCHX,DIQ,DR,DA,BCHG,BCHY S BCHY=$P(^BCHR(REC,0),U,3) I '$D(BCHY) S BCHY="???" Q BCHY Q BCHY PPAFFL(REC,FORM) ;EP - get pp affiliation internal or external NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHAFFL S BCHY=$P(^BCHR(REC,0),U,3) I 'BCHY S BCHAFFL="?" Q BCHAFFL I '$D(^VA(200,BCHY)) S BCHAFFL="?" Q BCHAFFL S DA=BCHY,DIC=200,DR=9999999.01,DIQ="BCHAFFL" S:$G(FORM)="I" DIQ(0)="I" D EN^DIQ1 S BCHAFFL=$S($G(FORM)="I":BCHAFFL(200,BCHY,9999999.01,"I"),1:BCHAFFL(200,BCHY,"9999999.01")) S:BCHAFFL="" BCHAFFL="?" Q BCHAFFL PPCLS(REC,FORM) ;EP GET primary provider discipline (internal or text) NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHCLS S BCHY=$P(^BCHR(REC,0),U,3) I 'BCHY S BCHCLS="???" Q BCHCLS S DA=BCHY,DIC=200,DR=53.5,DIQ="BCHCLS" S:$G(FORM)="I" DIQ(0)="I" D EN^DIQ1 S BCHCLS=$S($G(FORM)="I":$G(BCHCLS(200,BCHY,53.5,"I")),1:$G(BCHCLS(200,BCHY,"53.5"))) S:BCHCLS="" BCHCLS="???" Q BCHCLS PPCLSC(REC) ;EP GET PRIMARY PROVIDER CLASS CODE NEW X,Y,CODE,DIC,DR,DA,DIQ,CLS S CLS=$$PPCLS^BCHUTIL(REC,"I") I CLS="???" S CODE="???" Q CODE S DIC=7,DR="9999999.01",DA=CLS,DIQ="CODE" D EN^DIQ1 S CODE=CODE(7,CLS,"9999999.01") S:CODE="" CODE="???" Q CODE CALLDIE ;EP Q:'$D(DA) Q:'$D(DIE) Q:'$D(DR) D ^DIE K DIE,DIC,DR,DA,D0,D,D1,DO,%X,%Y,X,A,Z,DIU,DIV,DIY,DIW,DIADD,DLAYGO,%,%E,%D,%W,DI,DIFLD,DIG,DIH,DK,DL,DISYS Q PROVCLC(PROV) ;get provider class code, not using fileman DIQ1 NEW CODE,A S CODE="" I 'PROV Q CODE S A=$P($G(^VA(200,PROV,"PS")),U,5) I A="" Q CODE S CODE=$P($G(^DIC(7,A,9999999)),U) Q CODE CANNEDN() ;EP - return canned narrative ;*****CALLED FROM SCREENMAN I $$GET^DDSVAL(90002.01,.DA,.01,"","I")="" Q "" I $$GET^DDSVAL(90002.01,.DA,.04,"","I")="" Q $P(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U) Q $E($P(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)_":"_$P(^BCHTSERV($$GET^DDSVAL(90002.01,.DA,.04,"","I"),0),U),1,80) UPDPCC ;EP - called when pcc adds a visit ;if it is initiated by chr (i.e. BCHEV exists) chr will store ;ien's of visit and v file entries Q:'$D(BCHEV) ;quit if not initiated by chr Q:'$G(BCHEV("CHR IEN")) ;quit if don't know chr record ien Q:'$D(BCHV) ;quit if no pcc data passed back S DIE="^BCHR(",DA=BCHEV("CHR IEN"),DR=".15////"_BCHV("VISIT","9000010") D CALLDIE K Y,DA,DR,DIE S BCHX=0 F S BCHX=$O(BCHV("VFILES",BCHX)) Q:BCHX'=+BCHX D .S BCHY=0 F S BCHY=$O(BCHV("VFILES",BCHX,BCHY)) Q:BCHY'=+BCHY D ..S DA=BCHEV("CHR IEN"),DR="3101///""`"_BCHX_"""",DIE="^BCHR(" ..S DR(2,90002.03101)=".02////"_BCHY ..D CALLDIE ..K DIE,DA,DR,Y,X ..Q .Q K BCHX,BCHY Q