- 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