- 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 Mar 13, 2025@21:51:16 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
