source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGOINPT1.m@ 636

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