DGOREL1 ;ALB/MAC - PATIENT OUTPUT BY RELIGIOUS AFFILIATIONS (Cont.) ; 5/25/18 8:31am
;;5.3;Registration;**162,958**;Aug 13, 1993;Build 2
START D NOW^%DTC S Y=$E(%,1,12) S DGDT=$$FMTE^XLFDT(Y,1),(DGJ,DGJJ,DGP,DFN,DGW,DGF,DGFLAG,DGU,DGRM)=0,$P(DGCL,"*",81)="",$P(DGCL1,"-",81)=""
I DGL="D" F DGDA=DGBEG:0 S DGDA=$O(^DGPM("AMV1",DGDA)) Q:'DGDA F DFN=0:0 S DFN=$O(^DGPM("AMV1",DGDA,DFN)) Q:'DFN F DGCA=0:0 S DGCA=$O(^DGPM("AMV1",DGDA,DFN,DGCA)) Q:'DGCA I $D(^DGPM(DGCA,0)) I DGDA<DGEND D SET1
I DGL="D" G PR
F X1=0:0 S DGW=$S(VAUTW:$O(^DPT("CN",DGW)),1:$O(VAUTW(DGW))) Q:DGW=""!(DGU) D DIV,DGSET:'DGF
PR I $D(^UTILITY($J,"DGC")) S DGFL=0,DGPG=0 D:IOST?1"C-".E&(DGFLAG) RET I 'DGU D DGUTIL
I '$D(^UTILITY($J,"DGC")) W !,"=====>NO PATIENTS FOUND"
G QUIT
DIV S DGDN=$O(^DIC(42,"B",DGW,0)) Q:DGDN="" I $D(^DIC(42,DGDN,0)) S DGDN=$P(^DIC(42,DGDN,0),"^",11),DGF=$S('VAUTD&('$D(VAUTD(+DGDN))):1,1:0) S DGD=$S(DGDN="":"ZNOT SPECIFIED",1:$P(^DG(40.8,DGDN,0),"^",1))
Q
DGUTIL S (DGD,DGW)=0
F J1=0:0 S DGD=$O(^UTILITY($J,"DGC",DGD)) Q:DGD=""!(DGU) D
. F D1=0:0 S DGW=$O(^UTILITY($J,"DGC",DGD,DGW)) Q:DGW=""!(DGU) D RET:DGJ=-1 Q:DGU S DGPG=0 D HEAD F P1=0:0 S DGJ=$O(^UTILITY($J,"DGC",DGD,DGW,DGJ)) S:DGJ="" DGJ=-1 Q:DGJ<0!(DGU) D RELP,CONT
Q
CONT F D1=0:0 S DGP=$O(^UTILITY($J,"DGC",DGD,DGW,DGJ,DGP)) Q:DGP=""!(DGU) F DFN=0:0 S DFN=$O(^UTILITY($J,"DGC",DGD,DGW,DGJ,DGP,DFN)) Q:'DFN!(DGU) S DGUT=^(DFN) D DGPR W !
Q
DGSET F DFN=0:0 S DFN=$O(^DPT("CN",DGW,DFN)) Q:'DFN S DGCA=^(DFN) Q:'$D(^DGPM(+DGCA,0)) I $P(^DGPM(DGCA,0),"^",2)=1 S DGAD=^(0) D SET
Q
SET1 S DGDD=$P(^DGPM(DGCA,0),"^",17) I DGDD]"" Q:+^DGPM(+DGDD,0)<DGEND
S DGAD=^DGPM(DGCA,0) Q:'$D(^DPT(DFN,.1)) S DGW=^(.1) Q:DGW="" Q:('VAUTW)&('$D(VAUTW(DGW))) D DIV Q:DGF
SET S DGDAT=^DPT(DFN,0),DGREL=$S($D(^DIC(13,+$P(DGDAT,"^",8),0)):$P(^(0),"^",1),1:"ZNOT SPECIFIED") Q:DGNON=2&(DGREL="ZNOT SPECIFIED") I $D(DGR) Q:DGR'=DGREL
D PID^VADPT6 S DGRM=$S($D(^DPT(DFN,.101)):^(.101),1:"") I DGHOW["W" S ^UTILITY($J,"DGC",$E(DGD,1,20),$E(DGW,1,20),$E(DGREL,1,19),$E($P(DGDAT,"^",1),1,20),DFN)=$P(DGDAT,"^",1)_"^"_VA("PID")_"^"_+DGAD_"^"_DGRM Q
S ^UTILITY($J,"DGC",$E(DGD,1,20),$E(DGREL,1,19),$E(DGW,1,20),$E($P(DGDAT,"^",1),1,20),DFN)=$P(DGDAT,"^",1)_"^"_VA("PID")_"^"_+DGAD_"^"_DGRM Q
Q
RET Q:IOST'?1"C-".E F X=$Y:1:(IOSL-2) W !
R ?22,"Enter <RET> to continue or ^ to QUIT ",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU S DGFLAG=1 Q
RELP I $Y+6>IOSL D RET:(IOST?1"C-".E) Q:DGU D HEAD
W:DGFL DGCL1 W !,$S(DGHOW["W":"RELIGION: ",1:"WARD: "),$S(DGJ'="ZNOT SPECIFIED":DGJ,1:$E(DGJ,2,14)),! S DGFL=1 Q
; DG*5.3*958, truncate SSN to last four numbers and display at tab 43
DGPR ;D:$Y+4>IOSL RELP Q:DGU W ?3,$P(DGUT,"^",4),?15,$P(DGUT,"^",1),?40,$P(DGUT,"^",2),?58 S Y=$P(DGUT,"^",3) X ^DD("DD") W Y Q
D:$Y+4>IOSL RELP Q:DGU W ?3,$P(DGUT,"^",4),?15,$P(DGUT,"^",1),?43,$E($P(DGUT,"^",2),8,11),?58 S Y=$P(DGUT,"^",3) X ^DD("DD") W Y Q
HEAD S DGPG=DGPG+1 W @IOF,!?3,"DIVISION: ",$S(DGD="ZNOT SPECIFIED":"NOT SPECIFIED",1:DGD),?50,DGDT,?63," PAGE ",DGPG,!?24,"INPATIENT RELIGIOUS AFFILIATIONS",!
S DGSP="LISTING BY "_$S(DGHOW["W":"WARD - ",1:"FAITH - ")_$S(DGW'="ZNOT SPECIFIED":DGW,1:$E(DGW,2,14)),DGSP1=40-($L(DGSP)/2)\1,DGFL=0 W ?DGSP1,DGSP,!
I DGL="D" S DGT=$S(DGBEG1=DGEND1:"FOR ",1:"FROM ") S DGT=DGT_$$FMTE^XLFDT(DGBEG1,"1D") I DGEND1'=DGBEG1 S DGT=DGT_" TO "_$$FMTE^XLFDT(DGEND1,"1D")
I DGL="C" S DGT="FOR "_$P(DGDT,"@",1)
S DGY=40-($L(DGT)/2) W ?DGY,DGT,!!?4,"ROOM",?20,"PATIENT",?43,"PT ID",?60,"ADMISSION DATE",!,DGCL Q
QUIT D CLOSE^DGUTQ
QUIT1 K %,D1,DIC,DFN,DGAD,DGBEG,DGBEG1,DGCA,DGCL,DGCL1,DGDAT,DGDT,DGF,DGD,DGDN,DGDV,DGEND,DGEND1,DGFL,DGFLAG,DGHOW,DGJ,DGJJ,DGL,DGN,DGNON,DGP,DGPG,DGPGM,DGR,DGREL,DGRM
K DGDA,DGDD,DGSP,DGSP1,DGT,DGU,DGUT,DGVAR,DGW,DGWN,DGY,J1,P1,POP,VA("BID"),VA("PID"),VAUTD,VADAT,VADATE,VAUTNI,VAUTW,I,X,X1,Y,Z,^UTILITY($J,"DGC") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOREL1 3867 printed Dec 13, 2024@02:46:42 Page 2
DGOREL1 ;ALB/MAC - PATIENT OUTPUT BY RELIGIOUS AFFILIATIONS (Cont.) ; 5/25/18 8:31am
+1 ;;5.3;Registration;**162,958**;Aug 13, 1993;Build 2
START DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
SET DGDT=$$FMTE^XLFDT(Y,1)
SET (DGJ,DGJJ,DGP,DFN,DGW,DGF,DGFLAG,DGU,DGRM)=0
SET $PIECE(DGCL,"*",81)=""
SET $PIECE(DGCL1,"-",81)=""
+1 IF DGL="D"
FOR DGDA=DGBEG:0
SET DGDA=$ORDER(^DGPM("AMV1",DGDA))
if 'DGDA
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DGPM("AMV1",DGDA,DFN))
if 'DFN
QUIT
FOR DGCA=0:0
SET DGCA=$ORDER(^DGPM("AMV1",DGDA,DFN,DGCA))
if 'DGCA
QUIT
IF $DATA(^DGPM(DGCA,0))
IF DGDA<DGEND
DO SET1
+2 IF DGL="D"
GOTO PR
+3 FOR X1=0:0
SET DGW=$SELECT(VAUTW:$ORDER(^DPT("CN",DGW)),1:$ORDER(VAUTW(DGW)))
if DGW=""!(DGU)
QUIT
DO DIV
if 'DGF
DO DGSET
PR IF $DATA(^UTILITY($JOB,"DGC"))
SET DGFL=0
SET DGPG=0
if IOST?1"C-".E&(DGFLAG)
DO RET
IF 'DGU
DO DGUTIL
+1 IF '$DATA(^UTILITY($JOB,"DGC"))
WRITE !,"=====>NO PATIENTS FOUND"
+2 GOTO QUIT
DIV SET DGDN=$ORDER(^DIC(42,"B",DGW,0))
if DGDN=""
QUIT
IF $DATA(^DIC(42,DGDN,0))
SET DGDN=$PIECE(^DIC(42,DGDN,0),"^",11)
SET DGF=$SELECT('VAUTD&('$DATA(VAUTD(+DGDN))):1,1:0)
SET DGD=$SELECT(DGDN="":"ZNOT SPECIFIED",1:$PIECE(^DG(40.8,DGDN,0),"^",1))
+1 QUIT
DGUTIL SET (DGD,DGW)=0
+1 FOR J1=0:0
SET DGD=$ORDER(^UTILITY($JOB,"DGC",DGD))
if DGD=""!(DGU)
QUIT
Begin DoDot:1
+2 FOR D1=0:0
SET DGW=$ORDER(^UTILITY($JOB,"DGC",DGD,DGW))
if DGW=""!(DGU)
QUIT
if DGJ=-1
DO RET
if DGU
QUIT
SET DGPG=0
DO HEAD
FOR P1=0:0
SET DGJ=$ORDER(^UTILITY($JOB,"DGC",DGD,DGW,DGJ))
if DGJ=""
SET DGJ=-1
if DGJ<0!(DGU)
QUIT
DO RELP
DO CONT
End DoDot:1
+3 QUIT
CONT FOR D1=0:0
SET DGP=$ORDER(^UTILITY($JOB,"DGC",DGD,DGW,DGJ,DGP))
if DGP=""!(DGU)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^UTILITY($JOB,"DGC",DGD,DGW,DGJ,DGP,DFN))
if 'DFN!(DGU)
QUIT
SET DGUT=^(DFN)
DO DGPR
WRITE !
+1 QUIT
DGSET FOR DFN=0:0
SET DFN=$ORDER(^DPT("CN",DGW,DFN))
if 'DFN
QUIT
SET DGCA=^(DFN)
if '$DATA(^DGPM(+DGCA,0))
QUIT
IF $PIECE(^DGPM(DGCA,0),"^",2)=1
SET DGAD=^(0)
DO SET
+1 QUIT
SET1 SET DGDD=$PIECE(^DGPM(DGCA,0),"^",17)
IF DGDD]""
if +^DGPM(+DGDD,0)<DGEND
QUIT
+1 SET DGAD=^DGPM(DGCA,0)
if '$DATA(^DPT(DFN,.1))
QUIT
SET DGW=^(.1)
if DGW=""
QUIT
if ('VAUTW)&('$DATA(VAUTW(DGW)))
QUIT
DO DIV
if DGF
QUIT
SET SET DGDAT=^DPT(DFN,0)
SET DGREL=$SELECT($DATA(^DIC(13,+$PIECE(DGDAT,"^",8),0)):$PIECE(^(0),"^",1),1:"ZNOT SPECIFIED")
if DGNON=2&(DGREL="ZNOT SPECIFIED")
QUIT
IF $DATA(DGR)
if DGR'=DGREL
QUIT
+1 DO PID^VADPT6
SET DGRM=$SELECT($DATA(^DPT(DFN,.101)):^(.101),1:"")
IF DGHOW["W"
SET ^UTILITY($JOB,"DGC",$EXTRACT(DGD,1,20),$EXTRACT(DGW,1,20),$EXTRACT(DGREL,1,19),$EXTRACT($PIECE(DGDAT,"^",1),1,20),DFN)=$PIECE(DGDAT,"^",1)_"^"_VA("PID")_"^"_+DGAD_"^"_DGRM
QUIT
+2 SET ^UTILITY($JOB,"DGC",$EXTRACT(DGD,1,20),$EXTRACT(DGREL,1,19),$EXTRACT(DGW,1,20),$EXTRACT($PIECE(DGDAT,"^",1),1,20),DFN)=$PIECE(DGDAT,"^",1)_"^"_VA("PID")_"^"_+DGAD_"^"_DGRM
QUIT
+3 QUIT
RET if IOST'?1"C-".E
QUIT
FOR X=$Y:1:(IOSL-2)
WRITE !
+1 READ ?22,"Enter <RET> to continue or ^ to QUIT ",X:DTIME
if X["^"!('$TEST)
SET DGU=1
if DGU
QUIT
SET DGFLAG=1
QUIT
RELP IF $Y+6>IOSL
if (IOST?1"C-".E)
DO RET
if DGU
QUIT
DO HEAD
+1 if DGFL
WRITE DGCL1
WRITE !,$SELECT(DGHOW["W":"RELIGION: ",1:"WARD: "),$SELECT(DGJ'="ZNOT SPECIFIED":DGJ,1:$EXTRACT(DGJ,2,14)),!
SET DGFL=1
QUIT
+2 ; DG*5.3*958, truncate SSN to last four numbers and display at tab 43
DGPR ;D:$Y+4>IOSL RELP Q:DGU W ?3,$P(DGUT,"^",4),?15,$P(DGUT,"^",1),?40,$P(DGUT,"^",2),?58 S Y=$P(DGUT,"^",3) X ^DD("DD") W Y Q
+1 if $Y+4>IOSL
DO RELP
if DGU
QUIT
WRITE ?3,$PIECE(DGUT,"^",4),?15,$PIECE(DGUT,"^",1),?43,$EXTRACT($PIECE(DGUT,"^",2),8,11),?58
SET Y=$PIECE(DGUT,"^",3)
XECUTE ^DD("DD")
WRITE Y
QUIT
HEAD SET DGPG=DGPG+1
WRITE @IOF,!?3,"DIVISION: ",$SELECT(DGD="ZNOT SPECIFIED":"NOT SPECIFIED",1:DGD),?50,DGDT,?63," PAGE ",DGPG,!?24,"INPATIENT RELIGIOUS AFFILIATIONS",!
+1 SET DGSP="LISTING BY "_$SELECT(DGHOW["W":"WARD - ",1:"FAITH - ")_$SELECT(DGW'="ZNOT SPECIFIED":DGW,1:$EXTRACT(DGW,2,14))
SET DGSP1=40-($LENGTH(DGSP)/2)\1
SET DGFL=0
WRITE ?DGSP1,DGSP,!
+2 IF DGL="D"
SET DGT=$SELECT(DGBEG1=DGEND1:"FOR ",1:"FROM ")
SET DGT=DGT_$$FMTE^XLFDT(DGBEG1,"1D")
IF DGEND1'=DGBEG1
SET DGT=DGT_" TO "_$$FMTE^XLFDT(DGEND1,"1D")
+3 IF DGL="C"
SET DGT="FOR "_$PIECE(DGDT,"@",1)
+4 SET DGY=40-($LENGTH(DGT)/2)
WRITE ?DGY,DGT,!!?4,"ROOM",?20,"PATIENT",?43,"PT ID",?60,"ADMISSION DATE",!,DGCL
QUIT
QUIT DO CLOSE^DGUTQ
QUIT1 KILL %,D1,DIC,DFN,DGAD,DGBEG,DGBEG1,DGCA,DGCL,DGCL1,DGDAT,DGDT,DGF,DGD,DGDN,DGDV,DGEND,DGEND1,DGFL,DGFLAG,DGHOW,DGJ,DGJJ,DGL,DGN,DGNON,DGP,DGPG,DGPGM,DGR,DGREL,DGRM
+1 KILL DGDA,DGDD,DGSP,DGSP1,DGT,DGU,DGUT,DGVAR,DGW,DGWN,DGY,J1,P1,POP,VA("BID"),VA("PID"),VAUTD,VADAT,VADATE,VAUTNI,VAUTW,I,X,X1,Y,Z,^UTILITY($JOB,"DGC")
QUIT
