- DGPMOLD1 ;ALB/MIR - CONTINUATION OF LODGER OUTPUTS (SORT/PRINT) ;23 MAY 90 @12 [ 03/17/2004 1:52 PM ]
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- 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
- ;IHS/ITSC/WAR 03/17/04 Changed to $$GET1^DIQ
- ;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 facility
- 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($$GET1^DIQ(405,+J,.05):$$GET1^DIQ(405,+J,.05),1:"UNKNOWN") D SORT ;current lodgers 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
- ;IHS/ITSC/WAR 03/17/04 Changed to $$GET1^DIQ
- ;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 S W=$S($P(X,"^",18)=5:$S($D(^DIC(42,+$P(X,"^",6),0)):$P(^(0),"^",1),1:"UNKNOWN"),1:"ZZOF"_$S($$GET1^DIQ(405,+J,.05):$$GET1^DIQ(405,+J,.05),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
- DGPMOLD1 ;ALB/MIR - CONTINUATION OF LODGER OUTPUTS (SORT/PRINT) ;23 MAY 90 @12 [ 03/17/2004 1:52 PM ]
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- 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 ;IHS/ITSC/WAR 03/17/04 Changed to $$GET1^DIQ
- +4 ;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 facility
- +5 ;current lodgers 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($$GET1^DIQ(405,+J,.05):$$GET1^DIQ(405,+J,.05),1:"UNKNOWN")
- DO SORT
- +6 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 ;IHS/ITSC/WAR 03/17/04 Changed to $$GET1^DIQ
- +3 ;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)
- +4 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($$GET1^DIQ(405,+J,.05):$$GET1^DIQ(405,+J,.05),1:"UNKNOWN"))
- SET DGX=$PIECE(X,"^",6)
- IF DGX
- IF $SELECT(VAUTW
- QUIT
- +5 IF DGHOW=2
- IF DGX
- SET DGX=$SELECT($DATA(^DIC(42,+DGX,0)):$PIECE(^(0),"^",11),1:0)
- DO DIV
- IF DGX<0
- QUIT
- +6 SET DFN=$PIECE(X,"^",3)
- SET L=$SELECT($DATA(^DGPM(+J,"LD")):^("LD"),1:"")
- +7 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
