AZXARD ; IHS/PHXAO/TMJ -DISCLOSURE DISPLAY ;
;;2.0;RELEASE OF INFORMATION;;FEB 21, 2002
;
EP(AZXARIEN) ;PEP
START ;
Q:'$D(AZXARIEN)
Q:'AZXARIEN
Q:'$D(^AZXAREC(AZXARIEN,0))
K ^TMP("AZXARDSP",$J)
D BUILD
D EOJ
Q
;
BUILD ; build array
K AZXAAR
D TERM^VALM0
S AZXARREC=^AZXAREC(AZXARIEN,0)
S Y=$P(AZXARREC,U,3) D ^AUPNPAT
S AZXASTR="",AZXACTR=0
S AZXAH="Patient Name",AZXAV=IOINHI_$E($P(^DPT($P(AZXARREC,U,3),0),U),1,20)_IOINORM D BUILD1
S AZXAH="Chart #",AZXAV=IOINHI_$S($D(^AUPNPAT($P(AZXARREC,U,3),41,DUZ(2),0)):$P(^(0),U,2),1:"None")_IOINORM D BUILD1
S AZXAH="Date of Birth" S Y=AUPNDOB D DD^%DT S AZXAV=Y D BUILD1
S AZXAH="Sex",AZXAV=AUPNSEX D BUILD1
S AZXASTR="" D SET
REFERRAL ;
S AZXASTR="=============== "_IOINHI_"DISCLOSURE RECORD"_IOINORM_" ===============",X=(80-$L(AZXASTR)\2) D SET ;$J("",X)_AZXASTR D SET
K AZXAAR D ENP^XBDIQ1(1991075,AZXARIEN,".01:.49","AZXAAR(","E")
S F=0 F S F=$O(AZXAAR(F)) Q:F'=+F I AZXAAR(F)]"" D
.S AZXAH=$P(^DD(1991075,F,0),U)
.S AZXAV=AZXAAR(F)
.D BUILD1
S AZXASTR="" D SET
S AZXAH="PURPOSE OF DISCLOSURE",AZXAV=$$VAL^XBDIQ1(1991075,AZXARIEN,.07) D BUILD1,SET
2 ;
S AZXASTR="DISCLOSURE NOTES:" D SET
K AZXAAR D ENP^XBDIQ1(1991075,AZXARIEN,22,"AZXAAR(","E")
S F=0 F S F=$O(AZXAAR(22,F)) Q:F'=+F S AZXASTR=AZXAAR(22,F) D SET
S AZXASTR="" D SET
AUTH ;display Receiving Parties, similiar to v file
I '$D(^AZXAREC(AZXARIEN,23)) G VFILES
S AZXASTR="ROI RECEIVING PARTIES:" D SET
K AZXAAR D ENPM^XBDIQ1(1991075.023,"AZXARIEN,0",".01:.04","AZXAAR(")
S (I,F)=0 F S I=$O(AZXAAR(I)) Q:I'=+I S AZXASTR="" D SET S F=0 F S F=$O(AZXAAR(I,F)) Q:F'=+F D
.S AZXAH=$P(^DD(1991075.023,F,0),U)
.S AZXAV=AZXAAR(I,F)
.D BUILD1
S AZXASTR="" D SET
VFILES ;set up array of all v file entries
NEW DA,D0,DIC,DIQ,DR,DI
S AZXAVFLE=1991075 F AZXAVL=0:0 S AZXAVFLE=$O(^DIC(AZXAVFLE)) Q:AZXAVFLE>1991075.04!(AZXAVFLE'=+AZXAVFLE) D VF2
Q
;
VF2 ;
S AZXAVNM=$P(^DIC(AZXAVFLE,0),U),AZXAVDG=^DIC(AZXAVFLE,0,"GL"),AZXAVIGR=AZXAVDG_"""AD"",AZXARIEN,AZXAVDFN)",AZXAVDFN=""
F AZXAVI=1:1 S AZXAVDFN=$O(@AZXAVIGR) Q:AZXAVDFN="" D VF3
Q
;
VF3 ;
I AZXAVI<2 S AZXASTR="" D SET S AZXASTR="=============== "_IOINHI_AZXAVNM_"s"_IOINORM_" ===============",X=(80-$L(AZXASTR)\2) D SET ;$J("",X)_AZXASTR D SET
K AZXAAR D ENP^XBDIQ1(AZXAVFLE,AZXAVDFN,".01:.019999;.04:999999","AZXAAR(","E")
S AZXASTR="" D SET
S F=0 F S F=$O(AZXAAR(F)) Q:F'=+F D
.I $G(AZXAAR(F))]"" D
..S AZXAH=$P(^DD(AZXAVFLE,F,0),U)
..S AZXAV=AZXAAR(F)
..D BUILD1
.S G=0 F S G=$O(AZXAAR(F,G)) Q:G'=+G I $G(AZXAAR(F,G))]"" D
..S AZXASTR=AZXAAR(F,G)
..D SET
..Q
K G
Q
BUILD1 ;
S AZXASTR=$E(AZXAH,1,25)_":",AZXASTR=$$SETSTR^VALM1(AZXAV,AZXASTR,28,$L(AZXAV))
D SET
Q
SET ;set array
S AZXACTR=AZXACTR+1
S ^TMP("AZXARDSP",$J,AZXACTR,0)=AZXASTR
S AZXASTR=""
Q
;
EOJ ;
K AZXAAR,AZXASTR,AZXACTR,AZXAH,AZXARREC,AZXAV,AZXAVNM,AZXAVDG,AZXAVIGR,AZXAVDFN
Q
AZXARD ; IHS/PHXAO/TMJ -DISCLOSURE DISPLAY ;
+1 ;;2.0;RELEASE OF INFORMATION;;FEB 21, 2002
+2 ;
EP(AZXARIEN) ;PEP
START ;
+1 IF '$DATA(AZXARIEN)
QUIT
+2 IF 'AZXARIEN
QUIT
+3 IF '$DATA(^AZXAREC(AZXARIEN,0))
QUIT
+4 KILL ^TMP("AZXARDSP",$JOB)
+5 DO BUILD
+6 DO EOJ
+7 QUIT
+8 ;
BUILD ; build array
+1 KILL AZXAAR
+2 DO TERM^VALM0
+3 SET AZXARREC=^AZXAREC(AZXARIEN,0)
+4 SET Y=$PIECE(AZXARREC,U,3)
DO ^AUPNPAT
+5 SET AZXASTR=""
SET AZXACTR=0
+6 SET AZXAH="Patient Name"
SET AZXAV=IOINHI_$EXTRACT($PIECE(^DPT($PIECE(AZXARREC,U,3),0),U),1,20)_IOINORM
DO BUILD1
+7 SET AZXAH="Chart #"
SET AZXAV=IOINHI_$SELECT($DATA(^AUPNPAT($PIECE(AZXARREC,U,3),41,DUZ(2),0)):$PIECE(^(0),U,2),1:"None")_IOINORM
DO BUILD1
+8 SET AZXAH="Date of Birth"
SET Y=AUPNDOB
DO DD^%DT
SET AZXAV=Y
DO BUILD1
+9 SET AZXAH="Sex"
SET AZXAV=AUPNSEX
DO BUILD1
+10 SET AZXASTR=""
DO SET
REFERRAL ;
+1 ;$J("",X)_AZXASTR D SET
SET AZXASTR="=============== "_IOINHI_"DISCLOSURE RECORD"_IOINORM_" ==============="
SET X=(80-$LENGTH(AZXASTR)\2)
DO SET
+2 KILL AZXAAR
DO ENP^XBDIQ1(1991075,AZXARIEN,".01:.49","AZXAAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AZXAAR(F))
IF F'=+F
QUIT
IF AZXAAR(F)]""
Begin DoDot:1
+4 SET AZXAH=$PIECE(^DD(1991075,F,0),U)
+5 SET AZXAV=AZXAAR(F)
+6 DO BUILD1
End DoDot:1
+7 SET AZXASTR=""
DO SET
+8 SET AZXAH="PURPOSE OF DISCLOSURE"
SET AZXAV=$$VAL^XBDIQ1(1991075,AZXARIEN,.07)
DO BUILD1
DO SET
2 ;
+1 SET AZXASTR="DISCLOSURE NOTES:"
DO SET
+2 KILL AZXAAR
DO ENP^XBDIQ1(1991075,AZXARIEN,22,"AZXAAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AZXAAR(22,F))
IF F'=+F
QUIT
SET AZXASTR=AZXAAR(22,F)
DO SET
+4 SET AZXASTR=""
DO SET
AUTH ;display Receiving Parties, similiar to v file
+1 IF '$DATA(^AZXAREC(AZXARIEN,23))
GOTO VFILES
+2 SET AZXASTR="ROI RECEIVING PARTIES:"
DO SET
+3 KILL AZXAAR
DO ENPM^XBDIQ1(1991075.023,"AZXARIEN,0",".01:.04","AZXAAR(")
+4 SET (I,F)=0
FOR
SET I=$ORDER(AZXAAR(I))
IF I'=+I
QUIT
SET AZXASTR=""
DO SET
SET F=0
FOR
SET F=$ORDER(AZXAAR(I,F))
IF F'=+F
QUIT
Begin DoDot:1
+5 SET AZXAH=$PIECE(^DD(1991075.023,F,0),U)
+6 SET AZXAV=AZXAAR(I,F)
+7 DO BUILD1
End DoDot:1
+8 SET AZXASTR=""
DO SET
VFILES ;set up array of all v file entries
+1 NEW DA,D0,DIC,DIQ,DR,DI
+2 SET AZXAVFLE=1991075
FOR AZXAVL=0:0
SET AZXAVFLE=$ORDER(^DIC(AZXAVFLE))
IF AZXAVFLE>1991075.04!(AZXAVFLE'=+AZXAVFLE)
QUIT
DO VF2
+3 QUIT
+4 ;
VF2 ;
+1 SET AZXAVNM=$PIECE(^DIC(AZXAVFLE,0),U)
SET AZXAVDG=^DIC(AZXAVFLE,0,"GL")
SET AZXAVIGR=AZXAVDG_"""AD"",AZXARIEN,AZXAVDFN)"
SET AZXAVDFN=""
+2 FOR AZXAVI=1:1
SET AZXAVDFN=$ORDER(@AZXAVIGR)
IF AZXAVDFN=""
QUIT
DO VF3
+3 QUIT
+4 ;
VF3 ;
+1 ;$J("",X)_AZXASTR D SET
IF AZXAVI<2
SET AZXASTR=""
DO SET
SET AZXASTR="=============== "_IOINHI_AZXAVNM_"s"_IOINORM_" ==============="
SET X=(80-$LENGTH(AZXASTR)\2)
DO SET
+2 KILL AZXAAR
DO ENP^XBDIQ1(AZXAVFLE,AZXAVDFN,".01:.019999;.04:999999","AZXAAR(","E")
+3 SET AZXASTR=""
DO SET
+4 SET F=0
FOR
SET F=$ORDER(AZXAAR(F))
IF F'=+F
QUIT
Begin DoDot:1
+5 IF $GET(AZXAAR(F))]""
Begin DoDot:2
+6 SET AZXAH=$PIECE(^DD(AZXAVFLE,F,0),U)
+7 SET AZXAV=AZXAAR(F)
+8 DO BUILD1
End DoDot:2
+9 SET G=0
FOR
SET G=$ORDER(AZXAAR(F,G))
IF G'=+G
QUIT
IF $GET(AZXAAR(F,G))]""
Begin DoDot:2
+10 SET AZXASTR=AZXAAR(F,G)
+11 DO SET
+12 QUIT
End DoDot:2
End DoDot:1
+13 KILL G
+14 QUIT
BUILD1 ;
+1 SET AZXASTR=$EXTRACT(AZXAH,1,25)_":"
SET AZXASTR=$$SETSTR^VALM1(AZXAV,AZXASTR,28,$LENGTH(AZXAV))
+2 DO SET
+3 QUIT
SET ;set array
+1 SET AZXACTR=AZXACTR+1
+2 SET ^TMP("AZXARDSP",$JOB,AZXACTR,0)=AZXASTR
+3 SET AZXASTR=""
+4 QUIT
+5 ;
EOJ ;
+1 KILL AZXAAR,AZXASTR,AZXACTR,AZXAH,AZXARREC,AZXAV,AZXAVNM,AZXAVDG,AZXAVIGR,AZXAVDFN
+2 QUIT
