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

AZXARD.m

Go to the documentation of this file.
  1. AZXARD ; IHS/PHXAO/TMJ -DISCLOSURE DISPLAY ;
  1. ;;2.0;RELEASE OF INFORMATION;;FEB 21, 2002
  1. ;
  1. EP(AZXARIEN) ;PEP
  1. START ;
  1. Q:'$D(AZXARIEN)
  1. Q:'AZXARIEN
  1. Q:'$D(^AZXAREC(AZXARIEN,0))
  1. K ^TMP("AZXARDSP",$J)
  1. D BUILD
  1. D EOJ
  1. Q
  1. ;
  1. BUILD ; build array
  1. K AZXAAR
  1. D TERM^VALM0
  1. S AZXARREC=^AZXAREC(AZXARIEN,0)
  1. S Y=$P(AZXARREC,U,3) D ^AUPNPAT
  1. S AZXASTR="",AZXACTR=0
  1. S AZXAH="Patient Name",AZXAV=IOINHI_$E($P(^DPT($P(AZXARREC,U,3),0),U),1,20)_IOINORM D BUILD1
  1. 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
  1. S AZXAH="Date of Birth" S Y=AUPNDOB D DD^%DT S AZXAV=Y D BUILD1
  1. S AZXAH="Sex",AZXAV=AUPNSEX D BUILD1
  1. S AZXASTR="" D SET
  1. REFERRAL ;
  1. S AZXASTR="=============== "_IOINHI_"DISCLOSURE RECORD"_IOINORM_" ===============",X=(80-$L(AZXASTR)\2) D SET ;$J("",X)_AZXASTR D SET
  1. K AZXAAR D ENP^XBDIQ1(1991075,AZXARIEN,".01:.49","AZXAAR(","E")
  1. S F=0 F S F=$O(AZXAAR(F)) Q:F'=+F I AZXAAR(F)]"" D
  1. .S AZXAH=$P(^DD(1991075,F,0),U)
  1. .S AZXAV=AZXAAR(F)
  1. .D BUILD1
  1. S AZXASTR="" D SET
  1. S AZXAH="PURPOSE OF DISCLOSURE",AZXAV=$$VAL^XBDIQ1(1991075,AZXARIEN,.07) D BUILD1,SET
  1. 2 ;
  1. S AZXASTR="DISCLOSURE NOTES:" D SET
  1. K AZXAAR D ENP^XBDIQ1(1991075,AZXARIEN,22,"AZXAAR(","E")
  1. S F=0 F S F=$O(AZXAAR(22,F)) Q:F'=+F S AZXASTR=AZXAAR(22,F) D SET
  1. S AZXASTR="" D SET
  1. AUTH ;display Receiving Parties, similiar to v file
  1. I '$D(^AZXAREC(AZXARIEN,23)) G VFILES
  1. S AZXASTR="ROI RECEIVING PARTIES:" D SET
  1. K AZXAAR D ENPM^XBDIQ1(1991075.023,"AZXARIEN,0",".01:.04","AZXAAR(")
  1. 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
  1. .S AZXAH=$P(^DD(1991075.023,F,0),U)
  1. .S AZXAV=AZXAAR(I,F)
  1. .D BUILD1
  1. S AZXASTR="" D SET
  1. VFILES ;set up array of all v file entries
  1. NEW DA,D0,DIC,DIQ,DR,DI
  1. S AZXAVFLE=1991075 F AZXAVL=0:0 S AZXAVFLE=$O(^DIC(AZXAVFLE)) Q:AZXAVFLE>1991075.04!(AZXAVFLE'=+AZXAVFLE) D VF2
  1. Q
  1. ;
  1. VF2 ;
  1. S AZXAVNM=$P(^DIC(AZXAVFLE,0),U),AZXAVDG=^DIC(AZXAVFLE,0,"GL"),AZXAVIGR=AZXAVDG_"""AD"",AZXARIEN,AZXAVDFN)",AZXAVDFN=""
  1. F AZXAVI=1:1 S AZXAVDFN=$O(@AZXAVIGR) Q:AZXAVDFN="" D VF3
  1. Q
  1. ;
  1. VF3 ;
  1. 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
  1. K AZXAAR D ENP^XBDIQ1(AZXAVFLE,AZXAVDFN,".01:.019999;.04:999999","AZXAAR(","E")
  1. S AZXASTR="" D SET
  1. S F=0 F S F=$O(AZXAAR(F)) Q:F'=+F D
  1. .I $G(AZXAAR(F))]"" D
  1. ..S AZXAH=$P(^DD(AZXAVFLE,F,0),U)
  1. ..S AZXAV=AZXAAR(F)
  1. ..D BUILD1
  1. .S G=0 F S G=$O(AZXAAR(F,G)) Q:G'=+G I $G(AZXAAR(F,G))]"" D
  1. ..S AZXASTR=AZXAAR(F,G)
  1. ..D SET
  1. ..Q
  1. K G
  1. Q
  1. BUILD1 ;
  1. S AZXASTR=$E(AZXAH,1,25)_":",AZXASTR=$$SETSTR^VALM1(AZXAV,AZXASTR,28,$L(AZXAV))
  1. D SET
  1. Q
  1. SET ;set array
  1. S AZXACTR=AZXACTR+1
  1. S ^TMP("AZXARDSP",$J,AZXACTR,0)=AZXASTR
  1. S AZXASTR=""
  1. Q
  1. ;
  1. EOJ ;
  1. K AZXAAR,AZXASTR,AZXACTR,AZXAH,AZXARREC,AZXAV,AZXAVNM,AZXAVDG,AZXAVIGR,AZXAVDFN
  1. Q