Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDVDSB

APCDVDSB.m

Go to the documentation of this file.
APCDVDSB ; IHS/CMI/LAB -VISIT DISPLAY W/LIMITED LAB ELEMENTS ; 02 Nov 2015  11:45 AM
 ;;2.0;IHS PCC SUITE;**2,4,5,10,11,13,17**;MAY 14, 2009;Build 18
 ;
EN(APCDVIEN,APCDARRY) ;EP
 I $G(APCDARRY)="" S APCDARRY="^TMP(""APCDVDSG"",$J)"
 Q:'$D(APCDVIEN)
 Q:'APCDVIEN
 Q:'$D(^AUPNVSIT(APCDVIEN,0))
 D BUILD
 D XIT
 Q
 ;
SET ;set array
 S APCDCTR=APCDCTR+1
 S @APCDARRY@(APCDCTR,0)=APCDSTR
 S APCDSTR=""
 Q
BUILD ; build array
 K APCDAR
 D TERM^VALM0
 S APCDVREC=^AUPNVSIT(APCDVIEN,0)
 S Y=$P(APCDVREC,U,5) D ^AUPNPAT
 S APCDSTR="",APCDCTR=0
 S APCDH="Patient Name",APCDV=IOINHI_$E($P(^DPT($P(APCDVREC,U,5),0),U),1,20)_IOINORM D BUILD1
 S APCDH="Chart #",APCDV=IOINHI_$S($D(^AUPNPAT($P(APCDVREC,U,5),41,DUZ(2),0)):$P(^(0),U,2),1:"None")_IOINORM D BUILD1
 S APCDH="Date of Birth" S Y=AUPNDOB D DD^%DT S APCDV=Y D BUILD1
 S APCDH="Sex",APCDV=AUPNSEX D BUILD1
 S APCDH="Visit IEN",APCDV=APCDVIEN D BUILD1
 S APCDSTR="" D SET
VISIT ;
 S APCDSTR="=============== "_IOINHI_"VISIT FILE"_IOINORM_" ===============",X=(80-$L(APCDSTR)\2) D SET ;$J("",X)_APCDSTR D SET
 S F=0 F  S F=$O(^DD(9000010,F)) Q:F'=+F!(F>999999)  D
 .K APCDAR,APCDNARR
 .I +$P(^DD(9000010,F,0),U,2) D  Q  ;MULTIPLE AND WP FIELDS
 ..S APCDF=+$P(^DD(9000010,F,0),U,2)
 ..I $P($G(^DD(APCDF,.01,0)),U,2)'["W" D  Q  ;multiple
 ...D GETS^DIQ(9000010,APCDVIEN_",",F_"*","","APCDAR")
 ...I '$D(APCDAR) Q
 ...;S APCDSTR="" D SET
 ...S APCDJ="" F  S APCDJ=$O(APCDAR(APCDF,APCDJ)) Q:APCDJ=""  D
 ....S APCDF1=0 F  S APCDF1=$O(APCDAR(APCDF,APCDJ,APCDF1)) Q:APCDF1=""  D
 .....S APCDH=$P(^DD(APCDF,APCDF1,0),U,1)  ;field name
 .....I $O(APCDAR(APCDF,APCDJ,APCDF1,0)) D  Q
 ......S APCDSTR=APCDH_":" D SET
 ......S X=0 F  S X=$O(APCDAR(APCDF,APCDJ,APCDF1,X)) Q:X'=+X  S APCDSTR=APCDAR(APCDF,APCDJ,APCDF1,X) D SET
 .....S APCDV=APCDAR(APCDF,APCDJ,APCDF1)
 .....D BUILD1
 ..D GETS^DIQ(9000010,APCDVIEN_",",F,"","APCDAR")
 ..I $O(APCDAR(9000010,APCDVIEN_",",F,0)) D  Q  ;wp
 ...S APCDSTR=$P(^DD(9000010,F,0),U,1)_":" D SET
 ...S APCDNARR=""
 ...S F1=0 F  S F1=$O(APCDAR(9000010,APCDVIEN_",",F,F1)) Q:F1'=+F1  D
 ....S APCDV=APCDAR(9000010,APCDVIEN_",",F,F1)
 ....D BUILD1
 .K APCDNARR
 .I '+$P(^DD(9000010,F,0),U,2) D  ;SINGLE VALUED FIELD
 ..S APCDF=9000010
 ..D GETS^DIQ(APCDF,APCDVIEN_",",F,"E","APCDAR")
 ..I $G(APCDAR(APCDF,APCDVIEN_",",F,"E"))]"" D
 ...S APCDH=$P(^DD(9000010,F,0),U)
 ...S APCDV=APCDAR(APCDF,APCDVIEN_",",F,"E")
 ...D BUILD1
 ...Q
 I $O(^AUPNCANT(APCDVIEN,11,0)) D
 .S APCDSTR="" D SET
 .S APCDH=$P(^DD(9000095,1100,0),U)
 .S APCDV="" D BUILD1
 .S F=0 F  S F=$O(^AUPNCANT(APCDVIEN,11,F)) Q:F'=+F  D
 ..S APCDSTR=$G(^AUPNCANT(APCDVIEN,11,F,0)) D SET
 S APCDSTR="" D SET
 Q:'$P(APCDVREC,U,9)
VFILES ;set up array of all v file entries
 NEW DA,D0,DIC,DIQ,DR,DI
 S APCDVFLE=9000010 F  S APCDVFLE=$O(^DIC(APCDVFLE)) Q:APCDVFLE>9000010.99!(APCDVFLE'=+APCDVFLE)  D VF2
 D XIT
 Q
 ;
VF2 ;
 S APCDVNM=$P(^DIC(APCDVFLE,0),U),APCDVDG=^DIC(APCDVFLE,0,"GL"),APCDVIGR=APCDVDG_"""AD"",APCDVIEN,APCDVDFN)",APCDVDFN=""
 K APCDLABF
 I APCDVFLE=9000010.09 D
 .F X=.01,.04,1201,1202,1211,1108,1109,1110,1111,1401,1402,1601,1213,1113 S APCDLABF(X)=""  ;only these v lab fields
 S APCDVFC=0 F APCDVI=1:1 S APCDVDFN=$O(@APCDVIGR) Q:APCDVDFN=""  D VF3
 Q
 ;
VF3 ;
 I APCDVFLE=9000010.01 Q:$P($G(^AUPNVMSR(APCDVDFN,2)),U,1)  ;measurements entered in error
 I APCDVFLE=9000010.54 Q:$P($G(^AUPNVRUP(APCDVDFN,2)),U,1)  ;V updated/reviewed entered in error
 I APCDVFLE=9000010.62 Q:$P($G(^AUPNVAMI(APCDVDFN,5)),U,1)  ;V AMI entered in error
 I APCDVFLE=9000010.63 Q:$P($G(^AUPNVSTR(APCDVDFN,5)),U,1)  ;V STROKE entered in error
 I APCDVFLE=9000010.51 Q:$P($G(^AUPNVACG(APCDVDFN,1)),U,1)  ;V ANTICOAG entered in error
 I APCDVFLE=9000010.58 Q:$P($G(^AUPNVVI(APCDVDFN,0)),U,6)  ;V VI entered in error
 I APCDVFLE=9000010.43 Q:$P($G(^AUPNVOB(APCDVDFN,0)),U,6)  ;V OB entered in error
 S APCDVFC=APCDVFC+1
 I APCDVFC<2 S APCDSTR="" D SET S APCDSTR="=============== "_IOINHI_$P(APCDVNM,"V ",2)_"s"_IOINORM_" ===============",X=(80-$L(APCDSTR)\2) D SET ;$J("",X)_APCDSTR D SET
 I APCDVFC>1 S APCDSTR="" D SET
 S F=0 F  S F=$O(^DD(APCDVFLE,F)) Q:F'=+F!(F>999999)  D
 .I APCDVFLE=9000010.09,'$D(APCDLABF(F)) Q  ;only want certain lab fields
 .K APCDAR,APCDNARR
 .Q:F=".02"
 .Q:F=".03"
 .I +$P(^DD(APCDVFLE,F,0),U,2) D  Q  ;MULTIPLE AND WP FIELDS
 ..S APCDF=+$P(^DD(APCDVFLE,F,0),U,2)
 ..I $P($G(^DD(APCDF,.01,0)),U,2)'["W" D  Q  ;multiple
 ...D GETS^DIQ(APCDVFLE,APCDVDFN_",",F_"*","","APCDAR")
 ...S APCDSTR="" D SET
 ...S APCDJ="" F  S APCDJ=$O(APCDAR(APCDF,APCDJ)) Q:APCDJ=""  D
 ....S APCDF1=0 F  S APCDF1=$O(APCDAR(APCDF,APCDJ,APCDF1)) Q:APCDF1=""  D
 .....S APCDH=$P(^DD(APCDF,APCDF1,0),U,1)  ;field name
 .....I $O(APCDAR(APCDF,APCDJ,APCDF1,0)) D  Q
 ......S APCDSTR=APCDH_":" D SET
 ......S X=0 F  S X=$O(APCDAR(APCDF,APCDJ,APCDF1,X)) Q:X'=+X  S APCDSTR=APCDAR(APCDF,APCDJ,APCDF1,X) D SET
 .....S APCDV=APCDAR(APCDF,APCDJ,APCDF1)
 .....D BUILD1
 ..D GETS^DIQ(APCDVFLE,APCDVDFN_",",F,"","APCDAR")
 ..I $O(APCDAR(APCDVFLE,APCDVDFN_",",F,0)) D  Q  ;wp
 ...S APCDSTR=$P(^DD(APCDVFLE,F,0),U,1)_":" D SET
 ...S APCDNARR=""
 ...S F1=0 F  S F1=$O(APCDAR(APCDVFLE,APCDVDFN_",",F,F1)) Q:F1'=+F1  D
 ....S APCDV=APCDAR(APCDVFLE,APCDVDFN_",",F,F1)
 ....D BUILD1
 .K APCDNARR
 .I '+$P(^DD(APCDVFLE,F,0),U,2) D  ;SINGLE VALUED FIELD
 ..S APCDF=APCDVFLE
 ..D GETS^DIQ(APCDF,APCDVDFN_",",F,"E","APCDAR")
 ..I $G(APCDAR(APCDF,APCDVDFN_",",F,"E"))]"" D
 ...S APCDH=$P(^DD(APCDVFLE,F,0),U)
 ...S APCDV=APCDAR(APCDF,APCDVDFN_",",F,"E")
 ...D BUILD1
 ...I APCDVFLE=9000010.07,F=.01 D MAPADV(APCDVIEN,APCDVDFN)
 ...Q
 I APCDVFLE=9000010.28 S X=$P(^AUPNVNOT(APCDVDFN,0),U) D
 .I $$VAL^XBDIQ1(8925,X,.05)="RETRACTED" D
 ..S APCDH="RETRACTED DATE",APCDV=$$VAL^XBDIQ1(8925,X,1611) D BUILD1
 ..S APCDH="RETRACTED BY",APCDV=$$VAL^XBDIQ1(8925,X,1610) D BUILD1
 I APCDVFLE=9000010.01 D
 .;if entered in error, display reason
 I $G(DUZ(0))="@" S APCDH="V FILE IEN",APCDV=APCDVDFN D BUILD1  ;IHS/CMI/GRL
 Q
BUILD1 ;
 I $D(APCDNARR) S APCDSTR="",APCDSTR=$$SETSTR^VALM1(APCDV,APCDSTR,1,$L(APCDV)) D SET Q
 S APCDSTR=$E(APCDH,1,21)_":",APCDSTR=$$SETSTR^VALM1(APCDV,APCDSTR,24,$L(APCDV))
 D SET
 Q
 I $L(APCDSTR)>39 D SET
 S APCDV=" "_APCDV_" ",X=APCDH_": "_APCDV
 I $L(APCDSTR),$L(X)>40 D SET
 I $L(APCDSTR) S APCDSTR=$$SETSTR^VALM1(X,APCDSTR,40,$L(X))
 I '$L(APCDSTR) S APCDSTR=X
 K APCDV,APCDH,X
 Q
XIT ;
 K APCDLABF,APCDVFC,APCDAR,APCDARRY,APCDCTR,APCDH,APCDSTR,APCDV,APCDVDFN,APCDVDG,APCDVFLE,APCDVI,APCDVIEN,APCDVIGR,APCDFL,APCDVNM,APCDVREC,APCDH,APCDNARR,APCDF
 K DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z,F1
 Q
MAPADV(V,I) ;
 NEW F,D,C,APCDSMA
 S D=$$VD^APCLV(V)
 S D=$$IMP^AUPNSICD(D)
 I D'=30 Q  ;ICD10 ONLY
 S C=$$VAL^XBDIQ1(9000010.07,I,1101)
 ;GET MAP ADVICE
 S D=$$I10ADV^BSTSAPI("APCDSMA",C)
 I 'D Q  ;NO MAP ADVICE
 S APCDSTR="MAP ADVICE IS AVAILABLE"
 D SET
 Q