8:38 AM 4-NOV-98 CHR PACKAGE (BCH) PATCH 6 (includes patches 1-5) 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/26/97 4:15 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 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)(IOSL-6) D HEAD G:$D(BCHQUIT) DONE DONE ; D DONE^BCHUTIL1 K ^TMP("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,!,^TMP("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 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 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 BCHRC9 BCHRC9 ; IHS/TUCSON/LAB - CHRIS II Report 2 ; [ 09/21/98 10:44 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**6**;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 S (BCHBT,BCHBTH)=$H,BCHJOB=$J S ^TMP("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(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME)) S ^TMP("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(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)+1,$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)=$P(^TMP("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(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$P(^BCHRPROB(X,0),U,5),$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$P(^TMP("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(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$P(BCHR0,U,11),$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$P(BCHR0,U,11) .E D ..S $P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$P(^BCHRPROB(X,0),U,5),$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(^BCHRPROB(X,0),U,5) ;IHS/CMI/LAB - patch 6 modified ;IHS/CMI/LAB - patch 6 modified line below ..I C=1 S $P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$P(BCHR0,U,11),$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(BCHR0,U,11) .Q S $P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)+$P(BCHR0,U,12) S $P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)+$P(BCHR0,U,12) S N=$P(BCHR0,U,27)+$P(BCHR0,U,11) S $P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)+N,$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)=$P(^TMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)+N Q BCHRLP BCHRLP ; IHS/TUCSON/LAB - PRINT CHR RECORD REPORT ; [ 06/22/98 9:29 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**5**;OCT 28, 1996 ; ;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(^TMP("BCHRL",BCHJOB,BCHBTH)) G DONE S (BCHSRTV,BCHFRST)="" K BCHQUIT F S BCHSRTV=$O(^TMP("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(^TMP("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(^TMP("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 ^TMP("BCHLINE",$J) S ^TMP("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(^TMP("BCHLINE",$J,BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT) .W !,^TMP("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),^TMP("BCHLINE",$J,1)=^TMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^TMP("BCHLINE",$J,1)=^TMP("BCHLINE",$J,1)_" " .S X=1 F S X=$O(^TMP("BCHLINE",$J,X)) Q:X'=+X I $L(^TMP("BCHLINE",$J,X))<$L(^TMP("BCHLINE",$J,1)) S K=$L(^TMP("BCHLINE",$J,X))+1,J=$L(^TMP("BCHLINE",$J,1)) F I=K:1:J S ^TMP("BCHLINE",$J,X)=^TMP("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),^TMP("BCHLINE",$J,1)=^TMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^TMP("BCHLINE",$J,1)=^TMP("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),^TMP("BCHLINE",$J,1)=^TMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^TMP("BCHLINE",$J,1)=^TMP("BCHLINE",$J,1)_" " .S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNM(X),1,BCHLENG) D ..I '$D(^TMP("BCHLINE",$J,X)) S ^TMP("BCHLINE",$J,X)="",K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1,$P(^TMP("BCHLINE",$J,X)," ",($L(^TMP("BCHLINE",$J,1))-K))="" ..S J=$L(BCHPRNT),^TMP("BCHLINE",$J,X)=^TMP("BCHLINE",$J,X)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^TMP("BCHLINE",$J,X)=^TMP("BCHLINE",$J,X)_" " S X=1 F S X=$O(^TMP("BCHLINE",$J,X)) Q:X'=+X I $L(^TMP("BCHLINE",$J,X))<$L(^TMP("BCHLINE",$J,1)) S K=$L(^TMP("BCHLINE",$J,X))+1,J=$L(^TMP("BCHLINE",$J,1)) F I=K:1:J S ^TMP("BCHLINE",$J,X)=^TMP("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 BCHRLU BCHRLU ; IHS/TUCSON/LAB - TUCSON-OHPRD/LAB - GEN RETR UTILITIES ; [ 09/21/98 9:29 AM ] ;;1.0;IHS RPMS CHR SYSTEM;**6**;OCT 28, 1996 ; ;IHS/CMI/LAB - patch 6 replace BCHACE with D in MCR and PI MCR(P,D) ;is patient medicare eligible on this date NEW BCHMIFN,BCHFLG S BCHFLG=0 I '$D(^DPT(P,0)) G MCRX I $P(^DPT(P,0),U,19) G MCRX I '$D(^AUPNPAT(P,0)) G MCRX I '$D(^AUPNMCR(P,11)) G MCRX I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)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)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)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