source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGOREL1.m@ 636

DGOREL1 ;ALB/MAC - PATIENT OUTPUT BY RELIGIOUS AFFILIATIONS (Cont.) ; 5 JUL 88@12:00
 ;;5.3;Registration;**162**;Aug 13, 1993
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
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
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