DGPMOLD1 ;ALB/MIR - CONTINUATION OF LODGER OUTPUTS (SORT/PRINT) ;23 MAY 90 @12
;;5.3;Registration;;Aug 13, 1993
STORE D NOW^%DTC S Y=% X ^DD("DD") S DGNOW=Y I DGHOW=2 S Y=DGFR+.1 X ^DD("DD") S DGFROM=Y,Y=$P(DGTO,".") X ^DD("DD") S DGEND=Y
G:DGHOW=2 DR S W=""
F I=0:0 S W=$S(VAUTW:$O(^DGPM("LD",W)),1:$O(VAUTW(W))) Q:W="" S DGX=$O(^DIC(42,"B",W,0)),DGX=$S($D(^DIC(42,+DGX,0)):$P(^(0),"^",11),1:0) D DIV I DGX'<0 F J=0:0 S J=$O(^DGPM("LD",W,J)) Q:'J D SORT ;current lodgers
I DGOF F I=0:0 S I=$O(^DGPM("ATID4",I)) Q:'I S J=$O(^(I,0)),J=$O(^(+J,0)) I $D(^DGPM(+J,0)) S X=^(0) I '$P(X,"^",17),($P(X,"^",18)=6) S W="ZZOF"_$S($D(^DIC(4,+$P(X,"^",5),0)):$P(^(0),"^",1),1:"UNKNOWN") D SORT ;current lodgers/other facility
D PRINT Q
DR ;lodgers for a date range
F I=0:0 S I=$O(^DGPM("AMV4",I)) Q:'I!(I>DGTO) F K=0:0 S K=$O(^DGPM("AMV4",I,K)) Q:'K S J=$O(^(+K,0)) D SORT
D PRINT Q
SORT Q:'$D(^DGPM(+J,0)) S X=^(0),R=$P(X,"^",7) I DGHOW=2,'DGOF,($P(X,"^",18)=6) Q
I $D(^DGPM(+$P(X,"^",17),0)),(^(0)<DGFR) Q
I DGHOW=2 S W=$S($P(X,"^",18)=5:$S($D(^DIC(42,+$P(X,"^",6),0)):$P(^(0),"^",1),1:"UNKNOWN"),1:"ZZOF"_$S($D(^DIC(4,+$P(X,"^",5),0)):$P(^(0),"^",1),1:"UNKNOWN")),DGX=$P(X,"^",6) I DGX Q:$S(VAUTW:0,$D(VAUTW(DGX)):0,1:1)
I DGHOW=2,DGX S DGX=$S($D(^DIC(42,+DGX,0)):$P(^(0),"^",11),1:0) D DIV Q:DGX<0
S DFN=$P(X,"^",3),L=$S($D(^DGPM(+J,"LD")):^("LD"),1:"")
S ^UTILITY($J,"LOD",W,+X,$S($D(^DPT(+DFN,0)):$P(^(0),"^",1),1:"UNKNOWN PATIENT"))=DFN_"^"_R_"^"_$S($D(^DGPM(+$P(X,"^",17),0)):+^(0),1:"")_"^"_$S($D(^DGPM(+$P(X,"^",17),"LD")):$P(^("LD"),"^",3),1:"")_"^"_L Q
PRINT ;output for either type
S DGONE=1,(DGFL,DGPG)=0,W="" F I=0:0 S W=$O(^UTILITY($J,"LOD",W)) Q:W=""!DGFL D NEWWARD Q:DGFL F J=0:0 S J=$O(^UTILITY($J,"LOD",W,J)) Q:'J!DGFL S K=0 F L=0:0 S K=$O(^UTILITY($J,"LOD",W,J,K)) Q:K="" S DGX=^(K) D WRITE Q:DGFL
Q
WRITE D:DGONE!($Y>(IOSL-5)) HEAD Q:DGFL
W !,$E(K,1,25) S DFN=+DGX D PID^VADPT6 W ?27,$E(VA("BID"),1,8),?37 S Y=J X ^DD("DD") W Y,?59,$E($S($D(^DG(405.4,+$P(DGX,"^",2),0)):$P(^(0),"^",1),1:""),1,15),?76,$E($S($D(^DG(406.41,+$P(DGX,"^",5),0)):$P(^(0),"^",1),1:"UNKNOWN"),1,15)
I DGHOW=1 W ?98,$P(DGX,"^",6) Q
S Y=$P(DGX,"^",3) X ^DD("DD") W ?93,Y I $P(DGX,"^",3) S X1=$P(DGX,"^",3),X2=J D ^%DTC W ?115,$J($S(X:X,1:1),3)
W ?120,$S($P(DGX,"^",4)="":"",$P(DGX,"^",4)="a":"ADMITTED",1:"DISMISSED") I $P(DGX,"^",6)]"" W !?37,"COMMENTS: ",$P(DGX,"^",6)
Q
NEWWARD I DGONE!($Y>(IOSL-8)) D HEAD Q
I DGOF,(W=$O(^UTILITY($J,"LOD","ZZOF"))) S DGOF=2 D HEAD Q
D WARD Q
HEAD I $E(IOST)="C",'DGONE S DIR(0)="E" D ^DIR S DGFL='Y Q:DGFL
S DGPG=DGPG+1 I DGHOW=1 W @IOF,!,"CURRENT LODGERS " W:DGOF=2 "AT OTHER FACILITIES " W "AS OF ",DGNOW,?122,"PAGE: ",$J(DGPG,3)
I DGHOW=2 W @IOF,!,"LODGERS ",$S(DGOF'=2:"IN HOUSE",1:"AT OTHER FACILITIES")," BETWEEN ",DGFROM," AND ",DGEND,?122,"PAGE: ",$J(DGPG,3)
S DGONE=0 W !!,"PATIENT",?27,"SHORT ID",?37,"CHECKED IN",?59,"BED",?76,"REASON" I DGHOW=2 W ?93,"CHECKED OUT",?115,"LOS",?120,"DISPOSITION" K Z S $P(Z,"-",133)="" W !,Z D WARD Q
W ?98,"COMMENTS" K Z S $P(Z,"-",133)="" W !,Z D WARD Q
DIV I $S(VAUTD:0,$D(VAUTD(+DGX)):0,'DGX&$D(VAUTD($O(^DG(40.8,0)))):0,1:1) S DGX=-1
Q
WARD ;ward or facility print
I $E(W,1,4)'="ZZOF" W !!?(62-($L(W)/2)),W Q
S X=$P(W,"ZZOF",2) W !!?(60-($L(X)/2)),X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMOLD1 3301 printed Apr 09, 2024@21:52:04 Page 2
DGPMOLD1 ;ALB/MIR - CONTINUATION OF LODGER OUTPUTS (SORT/PRINT) ;23 MAY 90 @12
+1 ;;5.3;Registration;;Aug 13, 1993
STORE DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET DGNOW=Y
IF DGHOW=2
SET Y=DGFR+.1
XECUTE ^DD("DD")
SET DGFROM=Y
SET Y=$PIECE(DGTO,".")
XECUTE ^DD("DD")
SET DGEND=Y
+1 if DGHOW=2
GOTO DR
SET W=""
+2 ;current lodgers
FOR I=0:0
SET W=$SELECT(VAUTW:$ORDER(^DGPM("LD",W)),1:$ORDER(VAUTW(W)))
if W=""
QUIT
SET DGX=$ORDER(^DIC(42,"B",W,0))
SET DGX=$SELECT($DATA(^DIC(42,+DGX,0)):$PIECE(^(0),"^",11),1:0)
DO DIV
IF DGX'<0
FOR J=0:0
SET J=$ORDER(^DGPM("LD",W,J))
if 'J
QUIT
DO SORT
+3 ;current lodgers/other facility
IF DGOF
FOR I=0:0
SET I=$ORDER(^DGPM("ATID4",I))
if 'I
QUIT
SET J=$ORDER(^(I,0))
SET J=$ORDER(^(+J,0))
IF $DATA(^DGPM(+J,0))
SET X=^(0)
IF '$PIECE(X,"^",17)
IF ($PIECE(X,"^",18)=6)
SET W="ZZOF"_$SELECT($DATA(^DIC(4,+$PIECE(X,"^",5),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
DO SORT
+4 DO PRINT
QUIT
DR ;lodgers for a date range
+1 FOR I=0:0
SET I=$ORDER(^DGPM("AMV4",I))
if 'I!(I>DGTO)
QUIT
FOR K=0:0
SET K=$ORDER(^DGPM("AMV4",I,K))
if 'K
QUIT
SET J=$ORDER(^(+K,0))
DO SORT
+2 DO PRINT
QUIT
SORT if '$DATA(^DGPM(+J,0))
QUIT
SET X=^(0)
SET R=$PIECE(X,"^",7)
IF DGHOW=2
IF 'DGOF
IF ($PIECE(X,"^",18)=6)
QUIT
+1 IF $DATA(^DGPM(+$PIECE(X,"^",17),0))
IF (^(0)<DGFR)
QUIT
+2 IF DGHOW=2
SET W=$SELECT($PIECE(X,"^",18)=5:$SELECT($DATA(^DIC(42,+$PIECE(X,"^",6),0)):$PIECE(^(0),"^",1),1:"UNKNOWN"),1:"ZZOF"_$SELECT($DATA(^DIC(4,+$PIECE(X,"^",5),0)):$PIECE(^(0),"^",1),1:"UNKNOWN"))
SET DGX=$PIECE(X,"^",6)
IF DGX
if $SELECT(VAUTW
QUIT
+3 IF DGHOW=2
IF DGX
SET DGX=$SELECT($DATA(^DIC(42,+DGX,0)):$PIECE(^(0),"^",11),1:0)
DO DIV
if DGX<0
QUIT
+4 SET DFN=$PIECE(X,"^",3)
SET L=$SELECT($DATA(^DGPM(+J,"LD")):^("LD"),1:"")
+5 SET ^UTILITY($JOB,"LOD",W,+X,$SELECT($DATA(^DPT(+DFN,0)):$PIECE(^(0),"^",1),1:"UNKNOWN PATIENT"))=DFN_"^"_R_"^"_$SELECT($DATA(^DGPM(+$PIECE(X,"^",17),0)):+^(0),1:"")_"^"_$SELECT($DATA(^DGPM(+$PIECE(X,"^",17),"LD")):$PIECE(^("LD"),"^",3),1:"")_"
^"_L
QUIT
PRINT ;output for either type
+1 SET DGONE=1
SET (DGFL,DGPG)=0
SET W=""
FOR I=0:0
SET W=$ORDER(^UTILITY($JOB,"LOD",W))
if W=""!DGFL
QUIT
DO NEWWARD
if DGFL
QUIT
FOR J=0:0
SET J=$ORDER(^UTILITY($JOB,"LOD",W,J))
if 'J!DGFL
QUIT
SET K=0
FOR L=0:0
SET K=$ORDER(^UTILITY($JOB,"LOD",W,J,K))
if K=""
QUIT
SET DGX=^(K)
DO WRITE
if DGFL
QUIT
+2 QUIT
WRITE if DGONE!($Y>(IOSL-5))
DO HEAD
if DGFL
QUIT
+1 WRITE !,$EXTRACT(K,1,25)
SET DFN=+DGX
DO PID^VADPT6
WRITE ?27,$EXTRACT(VA("BID"),1,8),?37
SET Y=J
XECUTE ^DD("DD")
WRITE Y,?59,$EXTRACT($SELECT($DATA(^DG(405.4,+$PIECE(DGX,"^",2),0)):$PIECE(^(0),"^",1),1:""),1,15),?76,$EXTRACT($SELECT($DATA(^DG(406.41,+$PIECE(DGX,"^",5),0)):$PIECE(^(0),"^",1),1:"UNKNOWN"),1,15)
+2 IF DGHOW=1
WRITE ?98,$PIECE(DGX,"^",6)
QUIT
+3 SET Y=$PIECE(DGX,"^",3)
XECUTE ^DD("DD")
WRITE ?93,Y
IF $PIECE(DGX,"^",3)
SET X1=$PIECE(DGX,"^",3)
SET X2=J
DO ^%DTC
WRITE ?115,$JUSTIFY($SELECT(X:X,1:1),3)
+4 WRITE ?120,$SELECT($PIECE(DGX,"^",4)="":"",$PIECE(DGX,"^",4)="a":"ADMITTED",1:"DISMISSED")
IF $PIECE(DGX,"^",6)]""
WRITE !?37,"COMMENTS: ",$PIECE(DGX,"^",6)
+5 QUIT
NEWWARD IF DGONE!($Y>(IOSL-8))
DO HEAD
QUIT
+1 IF DGOF
IF (W=$ORDER(^UTILITY($JOB,"LOD","ZZOF")))
SET DGOF=2
DO HEAD
QUIT
+2 DO WARD
QUIT
HEAD IF $EXTRACT(IOST)="C"
IF 'DGONE
SET DIR(0)="E"
DO ^DIR
SET DGFL='Y
if DGFL
QUIT
+1 SET DGPG=DGPG+1
IF DGHOW=1
WRITE @IOF,!,"CURRENT LODGERS "
if DGOF=2
WRITE "AT OTHER FACILITIES "
WRITE "AS OF ",DGNOW,?122,"PAGE: ",$JUSTIFY(DGPG,3)
+2 IF DGHOW=2
WRITE @IOF,!,"LODGERS ",$SELECT(DGOF'=2:"IN HOUSE",1:"AT OTHER FACILITIES")," BETWEEN ",DGFROM," AND ",DGEND,?122,"PAGE: ",$JUSTIFY(DGPG,3)
+3 SET DGONE=0
WRITE !!,"PATIENT",?27,"SHORT ID",?37,"CHECKED IN",?59,"BED",?76,"REASON"
IF DGHOW=2
WRITE ?93,"CHECKED OUT",?115,"LOS",?120,"DISPOSITION"
KILL Z
SET $PIECE(Z,"-",133)=""
WRITE !,Z
DO WARD
QUIT
+4 WRITE ?98,"COMMENTS"
KILL Z
SET $PIECE(Z,"-",133)=""
WRITE !,Z
DO WARD
QUIT
DIV IF $SELECT(VAUTD:0,$DATA(VAUTD(+DGX)):0,'DGX&$DATA(VAUTD($ORDER(^DG(40.8,0)))):0,1:1)
SET DGX=-1
+1 QUIT
WARD ;ward or facility print
+1 IF $EXTRACT(W,1,4)'="ZZOF"
WRITE !!?(62-($LENGTH(W)/2)),W
QUIT
+2 SET X=$PIECE(W,"ZZOF",2)
WRITE !!?(60-($LENGTH(X)/2)),X
QUIT
