DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 8/8/03 11:45am
;;5.3;Registration;**162,498,544,732**;Aug 13, 1993;Build 2
;
;
; DGS1 IS USED FOR SORTING PRINT
; DGS2 IS USED FOR X-REF LOOKUP
ROSTER ;
S X=132 X ^%ZOSF("RM")
D NOW^%DTC S Y=$E(%,1,12),DGADMT=$$FMTE^XLFDT(Y,1)
S TOT=0,DGS="",DGS1=""
I DGHOW="W" S DGXREF="CN" D ROST
I DGHOW="P","EP"[DGPVAR S DGXREF="APR" D ROST
I DGHOW="P","EA"[DGPVAR S DGXREF="AAP" D ROST
I DGHOW="P",DGPVAR="E" D FIXTOT
D DOLIST
QUIT W !
K ^TMP($J),DGLIST,DGS,ROOMB,CPS,DFN,DGADMT,DGADM,DGCPYS,DGDAYS,DGDS,DGDV,DGI,DGJ,DGPGM,DGPMDD("DA"),DGVAR,DGWD,DGX,I,J,K,NM,TOT,VAUTD,VAUTW,WD,X,Y
K DGHOW,DGPVAR,DGS1,DGSUBS,DGTM,DGUTV,DIC,X1,XMDT,XMM,DGXREF,ZZ,DGPMIFN,DGS2,VADAT,VADATE,VADM,VAEL,VAIN,Z,DGTMPV,DGFL,DIR,DGBID
D KVAR^VADPT,KVAR^VADATE,CLOSE^DGUTQ,ENDREP^DGUTL
Q
FIXTOT ;
S DGS=""
F DGI=0:0 S DGS=$O(^TMP($J,"DGLIST",DGS)) Q:DGS="" D
.S DGUTV="^TMP("_$J_","""_DGS_""")"
.F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_","))
.S ^TMP($J,"DGLIST",DGS)=ZZ
Q
ROST ;
F DGI=0:0 S:DGS]""&TOT ^TMP($J,"DGLIST",DGS1)=TOT S TOT=0,DGS=$S((VAUTW):$O(^DPT(DGXREF,DGS)),1:$O(VAUTW(DGS))) Q:DGS="" D CHECK I DGFL S DFN="" F DGJ=0:0 S DFN=$O(^DPT(DGXREF,DGS2,DFN)) Q:DFN="" D ADMDT
Q
ADMDT ;
N DGVAIN7,VAL
D QKVADPT Q:'VAIN(7) S DGBID=VA("BID") S TOT=TOT+1,X=+VAIN(7),DGVAIN7="" I X S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0"),X=$TR(X,"/","-"),DGVAIN7=X
S DGPMIFN=VAIN(1) D ^DGPMLOS S DGDAYS=$P(X,"^",5)
S VAL=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_VAIN(4)_U_VAIN(5)_U_$P(VAIN(2),U,2)
S VAL=VAL_U_$P(VAIN(11),U,2)_U_$P(VAIN(3),U,2)_U_$P(VAEL(9),U,1)_U_$P(VAIP(19,1),U,1)
S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1)),+DGBID)=VAL
Q
CHECK ;
S DGFL=1
I DGHOW="P",VAUTW S DGS1=$S($D(^VA(200,DGS,0)):$P($G(^VA(200,DGS,0)),U,1),1:DGS),DGS2=DGS Q
I DGHOW="P",'VAUTW S DGS1=DGS,DGS2=VAUTW(DGS) Q
S DGWD=$O(^DIC(42,"B",DGS,0)) I DGWD S DGDV=$S('$D(^DIC(42,DGWD,0)):0,+$P(^(0),"^",11):$P(^(0),"^",11),1:$O(^DG(40.8,0)))
I 'VAUTD,'$D(VAUTD(DGDV)) S DGFL=0
S (DGS1,DGS2)=DGS
Q
WAIT I $E(IOST)="C" S DIR(0)="E" D ^DIR S:'Y DGX=1
Q
DOLIST ;
S DGX=0
F CPS=1:1:DGCPYS S DGS="" F I=0:0 S DGS=$O(^TMP($J,"DGLIST",DGS)) Q:DGS="" D HEAD,OUT G QTDOL:DGX D WAIT G QTDOL:DGX
QTDOL Q
HEAD S X=$S(DGHOW="W":"WARD",DGPVAR="E":"PROVIDER",DGPVAR="P":"PRIMARY PHYSICIAN",1:"ATTENDING PHYSICIAN")_": "_DGS_" "_^TMP($J,"DGLIST",DGS)_" PATIENTS"
W:IOF]"" @IOF W !!?4,"INPATIENT ROSTER",?(61-($L(X)/2)),X,?99 W DGADMT
W !!?33,"ADMISSION",?78,"PRIMARY",?95,"ATTENDING",?112,"TREATING",?126,"MEANS"
W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46,"DAYS",?52,"WARD",?67,"ROOM-BED",?78,"PHYSICIAN",?95,"PHYSICIAN",?112,"SPECIALTY",?126,"TEST" K X S $P(X,"-",133)="" W !,X,! Q
OUT ;
S DGUTV="^TMP("_$J_","""_DGS_""")"
F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_",")) S DGADM=@DGUTV D PRINT I $Y>(IOSL-6),($TR($Q(@DGUTV),"""")[($J_","_DGS_",")) D LEGEND,WAIT G QTOUT:DGX D HEAD
I $Y<(IOSL-5) D LEGEND
QTOUT Q
PRINT ;
W !,$S($P(DGADM,U,12):"!",1:""),$E($P(DGADM,U,1),1,19),?21,$P(DGADM,U,2),?28,$J($P(DGADM,U,3),3)
W ?33,$P(DGADM,U,4),?46,$J($P(DGADM,U,5),4),?52,$E($P(DGADM,U,6),1,14),?67,$E($P(DGADM,U,7),1,9),?78,$E($P(DGADM,U,8),1,15)
W ?95,$E($P(DGADM,U,9),1,15),?112,$E($P(DGADM,U,10),1,13),?128,$P(DGADM,U,11) W:DGDS !
Q
RM(ROOMB) ;
;IGNORES CHARACTERS BEFORE THE FIRST NON-ZERO NUMBER
;RETURNS NUMBERS IN ROOM-BED BEFORE THE FIRST '-' OR '/' THE REMAINING
;NUMBERS ARE DIVIDED BY 100,000 AND ADDED TO THE FIRST PART
; E.G. 'A-12E-A103C'
;WILL RETURN: 12.000103
;
NEW ROOM1,BEG
S ROOM1=$TR(ROOMB,"123456789","111111111")
S BEG=$F(ROOM1,1)-1
S ROOMB=$TR($E(ROOMB,BEG,99),"-/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ~!@#$%^&*()_+=`|\{}[]:"";'<>?,.","..")
S:$L(ROOMB,".")>1 ROOMB=$P(ROOMB,".",1)+(($TR(($P(ROOMB,".",2,99)),"."))/1000000)
Q +ROOMB
QKVADPT ;QUICK SUBSTITUTE FOR VADPT:REQUIRES DFN
NEW K,I,DGX
S K=0
F I=.105,.104,.103,.1,.101 S K=K+1,VAIN(K)=$G(^DPT(DFN,I))
S VAIN(11)=$G(^DPT(DFN,.1041))
S VAIN(7)=+$G(^DGPM(+VAIN(1),0))
F I=2,11 S:$D(^VA(200,+VAIN(I),0)) VAIN(I)=VAIN(I)_U_$P(^(0),U,1)
S:$D(^DIC(45.7,+VAIN(3),0)) VAIN(3)=VAIN(3)_U_$P(^(0),U,1)
;code added to differentiate ambiguous treating speialty names.
S:($E($P(VAIN(3),U,2),1,7)="NH LONG")!($E($P(VAIN(3),U,2),1,8)="NH SHORT") VAIN(3)=$P(^(0),U,2)_U_$P($G(^DIC(42.4,+$P(^(0),U,2),0)),U,2)
DEM S VADM(1)=$P($G(^DPT(DFN,0)),U,1)
S VAIP(19,1)=$P($G(^DGPM(+VAIN(1),"DIR")),"^",1)
S:VAIP(19,1)="" VAIP(19,1)=1
S DGX=$P($G(^DPT(DFN,0)),U,3)
S VADM(4)=$E(DT,1,3)-$E(DGX,1,3)-($E(DT,4,7)<$E(DGX,4,7))
D PID^VADPT6
MT S VAEL(9)=$P($$MTS^DGMTU(DFN),U,2)
Q
LEGEND F Q:($Y>(IOSL-5)) W !
W !,"'!' Before the Patient name indicates the patient chose not to be listed in the Facility Directory"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOINPT1 4926 printed Sep 23, 2025@20:22:30 Page 2
DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 8/8/03 11:45am
+1 ;;5.3;Registration;**162,498,544,732**;Aug 13, 1993;Build 2
+2 ;
+3 ;
+4 ; DGS1 IS USED FOR SORTING PRINT
+5 ; DGS2 IS USED FOR X-REF LOOKUP
ROSTER ;
+1 SET X=132
XECUTE ^%ZOSF("RM")
+2 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
SET DGADMT=$$FMTE^XLFDT(Y,1)
+3 SET TOT=0
SET DGS=""
SET DGS1=""
+4 IF DGHOW="W"
SET DGXREF="CN"
DO ROST
+5 IF DGHOW="P"
IF "EP"[DGPVAR
SET DGXREF="APR"
DO ROST
+6 IF DGHOW="P"
IF "EA"[DGPVAR
SET DGXREF="AAP"
DO ROST
+7 IF DGHOW="P"
IF DGPVAR="E"
DO FIXTOT
+8 DO DOLIST
QUIT WRITE !
+1 KILL ^TMP($JOB),DGLIST,DGS,ROOMB,CPS,DFN,DGADMT,DGADM,DGCPYS,DGDAYS,DGDS,DGDV,DGI,DGJ,DGPGM,DGPMDD("DA"),DGVAR,DGWD,DGX,I,J,K,NM,TOT,VAUTD,VAUTW,WD,X,Y
+2 KILL DGHOW,DGPVAR,DGS1,DGSUBS,DGTM,DGUTV,DIC,X1,XMDT,XMM,DGXREF,ZZ,DGPMIFN,DGS2,VADAT,VADATE,VADM,VAEL,VAIN,Z,DGTMPV,DGFL,DIR,DGBID
+3 DO KVAR^VADPT
DO KVAR^VADATE
DO CLOSE^DGUTQ
DO ENDREP^DGUTL
+4 QUIT
FIXTOT ;
+1 SET DGS=""
+2 FOR DGI=0:0
SET DGS=$ORDER(^TMP($JOB,"DGLIST",DGS))
if DGS=""
QUIT
Begin DoDot:1
+3 SET DGUTV="^TMP("_$JOB_","""_DGS_""")"
+4 FOR ZZ=0:1
SET DGUTV=$QUERY(@DGUTV)
if DGUTV=""!($TRANSLATE(DGUTV,"""")'[($JOB_","_DGS_","))
QUIT
+5 SET ^TMP($JOB,"DGLIST",DGS)=ZZ
End DoDot:1
+6 QUIT
ROST ;
+1 FOR DGI=0:0
if DGS]""&TOT
SET ^TMP($JOB,"DGLIST",DGS1)=TOT
SET TOT=0
SET DGS=$SELECT((VAUTW):$ORDER(^DPT(DGXREF,DGS)),1:$ORDER(VAUTW(DGS)))
if DGS=""
QUIT
DO CHECK
IF DGFL
SET DFN=""
FOR DGJ=0:0
SET DFN=$ORDER(^DPT(DGXREF,DGS2,DFN))
if DFN=""
QUIT
DO ADMDT
+2 QUIT
ADMDT ;
+1 NEW DGVAIN7,VAL
+2 DO QKVADPT
if 'VAIN(7)
QUIT
SET DGBID=VA("BID")
SET TOT=TOT+1
SET X=+VAIN(7)
SET DGVAIN7=""
IF X
SET X=$$FMTE^XLFDT(X,"5DF")
SET X=$TRANSLATE(X," ","0")
SET X=$TRANSLATE(X,"/","-")
SET DGVAIN7=X
+3 SET DGPMIFN=VAIN(1)
DO ^DGPMLOS
SET DGDAYS=$PIECE(X,"^",5)
+4 SET VAL=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_VAIN(4)_U_VAIN(5)_U_$PIECE(VAIN(2),U,2)
+5 SET VAL=VAL_U_$PIECE(VAIN(11),U,2)_U_$PIECE(VAIN(3),U,2)_U_$PIECE(VAEL(9),U,1)_U_$PIECE(VAIP(19,1),U,1)
+6 SET ^TMP($JOB,DGS1,$SELECT(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1)),+DGBID)=VAL
+7 QUIT
CHECK ;
+1 SET DGFL=1
+2 IF DGHOW="P"
IF VAUTW
SET DGS1=$SELECT($DATA(^VA(200,DGS,0)):$PIECE($GET(^VA(200,DGS,0)),U,1),1:DGS)
SET DGS2=DGS
QUIT
+3 IF DGHOW="P"
IF 'VAUTW
SET DGS1=DGS
SET DGS2=VAUTW(DGS)
QUIT
+4 SET DGWD=$ORDER(^DIC(42,"B",DGS,0))
IF DGWD
SET DGDV=$SELECT('$DATA(^DIC(42,DGWD,0)):0,+$PIECE(^(0),"^",11):$PIECE(^(0),"^",11),1:$ORDER(^DG(40.8,0)))
+5 IF 'VAUTD
IF '$DATA(VAUTD(DGDV))
SET DGFL=0
+6 SET (DGS1,DGS2)=DGS
+7 QUIT
WAIT IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
if 'Y
SET DGX=1
+1 QUIT
DOLIST ;
+1 SET DGX=0
+2 FOR CPS=1:1:DGCPYS
SET DGS=""
FOR I=0:0
SET DGS=$ORDER(^TMP($JOB,"DGLIST",DGS))
if DGS=""
QUIT
DO HEAD
DO OUT
if DGX
GOTO QTDOL
DO WAIT
if DGX
GOTO QTDOL
QTDOL QUIT
HEAD SET X=$SELECT(DGHOW="W":"WARD",DGPVAR="E":"PROVIDER",DGPVAR="P":"PRIMARY PHYSICIAN",1:"ATTENDING PHYSICIAN")_": "_DGS_" "_^TMP($JOB,"DGLIST",DGS)_" PATIENTS"
+1 if IOF]""
WRITE @IOF
WRITE !!?4,"INPATIENT ROSTER",?(61-($LENGTH(X)/2)),X,?99
WRITE DGADMT
+2 WRITE !!?33,"ADMISSION",?78,"PRIMARY",?95,"ATTENDING",?112,"TREATING",?126,"MEANS"
+3 WRITE !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46,"DAYS",?52,"WARD",?67,"ROOM-BED",?78,"PHYSICIAN",?95,"PHYSICIAN",?112,"SPECIALTY",?126,"TEST"
KILL X
SET $PIECE(X,"-",133)=""
WRITE !,X,!
QUIT
OUT ;
+1 SET DGUTV="^TMP("_$JOB_","""_DGS_""")"
+2 FOR ZZ=0:1
SET DGUTV=$QUERY(@DGUTV)
if DGUTV=""!($TRANSLATE(DGUTV,"""")'[($JOB_","_DGS_","))
QUIT
SET DGADM=@DGUTV
DO PRINT
IF $Y>(IOSL-6)
IF ($TRANSLATE($QUERY(@DGUTV),"""")[($JOB_","_DGS_","))
DO LEGEND
DO WAIT
if DGX
GOTO QTOUT
DO HEAD
+3 IF $Y<(IOSL-5)
DO LEGEND
QTOUT QUIT
PRINT ;
+1 WRITE !,$SELECT($PIECE(DGADM,U,12):"!",1:""),$EXTRACT($PIECE(DGADM,U,1),1,19),?21,$PIECE(DGADM,U,2),?28,$JUSTIFY($PIECE(DGADM,U,3),3)
+2 WRITE ?33,$PIECE(DGADM,U,4),?46,$JUSTIFY($PIECE(DGADM,U,5),4),?52,$EXTRACT($PIECE(DGADM,U,6),1,14),?67,$EXTRACT($PIECE(DGADM,U,7),1,9),?78,$EXTRACT($PIECE(DGADM,U,8),1,15)
+3 WRITE ?95,$EXTRACT($PIECE(DGADM,U,9),1,15),?112,$EXTRACT($PIECE(DGADM,U,10),1,13),?128,$PIECE(DGADM,U,11)
if DGDS
WRITE !
+4 QUIT
RM(ROOMB) ;
+1 ;IGNORES CHARACTERS BEFORE THE FIRST NON-ZERO NUMBER
+2 ;RETURNS NUMBERS IN ROOM-BED BEFORE THE FIRST '-' OR '/' THE REMAINING
+3 ;NUMBERS ARE DIVIDED BY 100,000 AND ADDED TO THE FIRST PART
+4 ; E.G. 'A-12E-A103C'
+5 ;WILL RETURN: 12.000103
+6 ;
+7 NEW ROOM1,BEG
+8 SET ROOM1=$TRANSLATE(ROOMB,"123456789","111111111")
+9 SET BEG=$FIND(ROOM1,1)-1
+10 SET ROOMB=$TRANSLATE($EXTRACT(ROOMB,BEG,99),"-/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ~!@#$%^&*()_+=`|\{}[]:"";'<>?,.","..")
+11 if $LENGTH(ROOMB,".")>1
SET ROOMB=$PIECE(ROOMB,".",1)+(($TRANSLATE(($PIECE(ROOMB,".",2,99)),"."))/1000000)
+12 QUIT +ROOMB
QKVADPT ;QUICK SUBSTITUTE FOR VADPT:REQUIRES DFN
+1 NEW K,I,DGX
+2 SET K=0
+3 FOR I=.105,.104,.103,.1,.101
SET K=K+1
SET VAIN(K)=$GET(^DPT(DFN,I))
+4 SET VAIN(11)=$GET(^DPT(DFN,.1041))
+5 SET VAIN(7)=+$GET(^DGPM(+VAIN(1),0))
+6 FOR I=2,11
if $DATA(^VA(200,+VAIN(I),0))
SET VAIN(I)=VAIN(I)_U_$PIECE(^(0),U,1)
+7 if $DATA(^DIC(45.7,+VAIN(3),0))
SET VAIN(3)=VAIN(3)_U_$PIECE(^(0),U,1)
+8 ;code added to differentiate ambiguous treating speialty names.
+9 if ($EXTRACT($PIECE(VAIN(3),U,2),1,7)="NH LONG")!($EXTRACT($PIECE(VAIN(3),U,2),1,8)="NH SHORT")
SET VAIN(3)=$PIECE(^(0),U,2)_U_$PIECE($GET(^DIC(42.4,+$PIECE(^(0),U,2),0)),U,2)
DEM SET VADM(1)=$PIECE($GET(^DPT(DFN,0)),U,1)
+1 SET VAIP(19,1)=$PIECE($GET(^DGPM(+VAIN(1),"DIR")),"^",1)
+2 if VAIP(19,1)=""
SET VAIP(19,1)=1
+3 SET DGX=$PIECE($GET(^DPT(DFN,0)),U,3)
+4 SET VADM(4)=$EXTRACT(DT,1,3)-$EXTRACT(DGX,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(DGX,4,7))
+5 DO PID^VADPT6
MT SET VAEL(9)=$PIECE($$MTS^DGMTU(DFN),U,2)
+1 QUIT
LEGEND FOR
if ($Y>(IOSL-5))
QUIT
WRITE !
+1 WRITE !,"'!' Before the Patient name indicates the patient chose not to be listed in the Facility Directory"
+2 QUIT
