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