ADGPTLP1 ; IHS/ADC/PDW/ENM - PRINT PATIENT ROSTER IN ALPHA ORDER ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
S DGPG=0,DGSTOP=""
S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
S DGX=^AUTTLOC(DUZ(2),0)
S DGCITY=$P(DGX,U,13)_","_$P(^DIC(5,+$P(DGX,U,14),0),U)
S (DGLIN,DGLIN1)="",$P(DGLIN,"-",80)="",$P(DGLIN1,"=",80)=""
D HEAD
;
S DGNM=""
A S DGNM=$O(^TMP("DGZPTL",$J,"A",DGNM)) G END:DGNM="" S DFN=0
A1 S DFN=$O(^TMP("DGZPTL",$J,"A",DGNM,DFN)) G A:DFN="" S DGSTR=^(DFN)
S DGRM=$P(DGSTR,U),DGAD=$P(DGSTR,U,2),DGSER=$P(DGSTR,U,3)
S DGPRV=$P(DGSTR,U,4),DGDS=$P(DGSTR,U,6)
S DGWARD=$P(DGRM,"-",1),DGBED=$P(DGRM,"-",2,3),DGLOS=""
K ^UTILITY("DIQ1",$J) S DA=DFN,DIC=2,DR=.033 D EN^DIQ1
S AGE=^UTILITY("DIQ1",$J,2,DFN,.033) K ^UTILITY("DIQ1",$J)
I DGAD'="" S X=$P(DGAD,".",1) D H^%DTC S DGLOS=(+$H-+%H)+1
S DGCHART=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),DGXX=6-$L(DGCHART)
F DGII=1:1:DGXX S DGCHART="0"_DGCHART
S:DGSER?1N.N DGSER=$P(^DIC(45.7,DGSER,0),U)
S:DGPRV?1N.N DGPRV=$P(^VA(200,DGPRV,0),U)
;
I $Y>(IOSL-5) D NEWPG G END1:DGSTOP=U
W !?1,DGWARD,?7,DGDS,?10,DGBED,?17,$E(DGNM,1,20)
W ?38,AGE,?43,$J(DGLOS,2),?48
W:DGCHART?1N.N $E(DGCHART,1,2)_"-"_$E(DGCHART,3,4)_"-"_$E(DGCHART,5,6)
W ?57,DGSER,!
W:DGPRV'="" ?17,"(",$E(DGPRV,1,15),")" W !
G A1
;
END I IOST["C-" K DIR S DIR(0)="E" D ^DIR
END1 G END1^ADGPTLP
;
;
NEWPG ;***> subrtn for end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPG>0) W @IOF
W !,DGLIN1 S DGPG=DGPG+1
W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !?80-$L(DGFAC)/2,DGFAC,!,DGDUZ
S DGTY="PATIENT ROSTER " W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPG
W ! D TIME^ADGUTIL W ?80-$L(DGCITY)/2,DGCITY
S Y=DT X ^DD("DD") W !?80-$L(Y)/2,Y
W !,DGLIN1
W !,"Ward",?10,"Room",?22,"Patient",?37,"Age",?42,"Days"
W ?49,"Chart",?59,"Service",!?22,"(Provider)",?51,"No."
W !,"----",?10,"----",?18,"-----------------",?37,"----"
W ?42,"----",?48,"-------",?57,"----------------"
W !
Q
ADGPTLP1 ; IHS/ADC/PDW/ENM - PRINT PATIENT ROSTER IN ALPHA ORDER ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 SET DGPG=0
SET DGSTOP=""
+4 SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+5 SET DGX=^AUTTLOC(DUZ(2),0)
+6 SET DGCITY=$PIECE(DGX,U,13)_","_$PIECE(^DIC(5,+$PIECE(DGX,U,14),0),U)
+7 SET (DGLIN,DGLIN1)=""
SET $PIECE(DGLIN,"-",80)=""
SET $PIECE(DGLIN1,"=",80)=""
+8 DO HEAD
+9 ;
+10 SET DGNM=""
A SET DGNM=$ORDER(^TMP("DGZPTL",$JOB,"A",DGNM))
IF DGNM=""
GOTO END
SET DFN=0
A1 SET DFN=$ORDER(^TMP("DGZPTL",$JOB,"A",DGNM,DFN))
IF DFN=""
GOTO A
SET DGSTR=^(DFN)
+1 SET DGRM=$PIECE(DGSTR,U)
SET DGAD=$PIECE(DGSTR,U,2)
SET DGSER=$PIECE(DGSTR,U,3)
+2 SET DGPRV=$PIECE(DGSTR,U,4)
SET DGDS=$PIECE(DGSTR,U,6)
+3 SET DGWARD=$PIECE(DGRM,"-",1)
SET DGBED=$PIECE(DGRM,"-",2,3)
SET DGLOS=""
+4 KILL ^UTILITY("DIQ1",$JOB)
SET DA=DFN
SET DIC=2
SET DR=.033
DO EN^DIQ1
+5 SET AGE=^UTILITY("DIQ1",$JOB,2,DFN,.033)
KILL ^UTILITY("DIQ1",$JOB)
+6 IF DGAD'=""
SET X=$PIECE(DGAD,".",1)
DO H^%DTC
SET DGLOS=(+$HOROLOG-+%H)+1
+7 SET DGCHART=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
SET DGXX=6-$LENGTH(DGCHART)
+8 FOR DGII=1:1:DGXX
SET DGCHART="0"_DGCHART
+9 IF DGSER?1N.N
SET DGSER=$PIECE(^DIC(45.7,DGSER,0),U)
+10 IF DGPRV?1N.N
SET DGPRV=$PIECE(^VA(200,DGPRV,0),U)
+11 ;
+12 IF $Y>(IOSL-5)
DO NEWPG
IF DGSTOP=U
GOTO END1
+13 WRITE !?1,DGWARD,?7,DGDS,?10,DGBED,?17,$EXTRACT(DGNM,1,20)
+14 WRITE ?38,AGE,?43,$JUSTIFY(DGLOS,2),?48
+15 IF DGCHART?1N.N
WRITE $EXTRACT(DGCHART,1,2)_"-"_$EXTRACT(DGCHART,3,4)_"-"_$EXTRACT(DGCHART,5,6)
+16 WRITE ?57,DGSER,!
+17 IF DGPRV'=""
WRITE ?17,"(",$EXTRACT(DGPRV,1,15),")"
WRITE !
+18 GOTO A1
+19 ;
END IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
END1 GOTO END1^ADGPTLP
+1 ;
+2 ;
NEWPG ;***> subrtn for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPG>0)
WRITE @IOF
+2 WRITE !,DGLIN1
SET DGPG=DGPG+1
+3 WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !?80-$LENGTH(DGFAC)/2,DGFAC,!,DGDUZ
+5 SET DGTY="PATIENT ROSTER "
WRITE ?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPG
+6 WRITE !
DO TIME^ADGUTIL
WRITE ?80-$LENGTH(DGCITY)/2,DGCITY
+7 SET Y=DT
XECUTE ^DD("DD")
WRITE !?80-$LENGTH(Y)/2,Y
+8 WRITE !,DGLIN1
+9 WRITE !,"Ward",?10,"Room",?22,"Patient",?37,"Age",?42,"Days"
+10 WRITE ?49,"Chart",?59,"Service",!?22,"(Provider)",?51,"No."
+11 WRITE !,"----",?10,"----",?18,"-----------------",?37,"----"
+12 WRITE ?42,"----",?48,"-------",?57,"----------------"
+13 WRITE !
+14 QUIT
