- 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 Feb 19, 2025@00:12:40 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