DGRUGPP1 ;ALB/BOK/MLI - PRINT PAI FOR A PATIENT ; 25 FEB 87 12:00
;;5.3;Registration;**89,173**;Aug 13, 1993
S DIC="^DG(45.9,",DIC(0)="AEQMZ" D ^DIC K DIC G QUIT:Y'>0 S DGPT=+Y
W !!,*7,!!,"THIS REPORT REQUIRES 132 COLUMN OUTPUT"
S DGPGM="START^DGRUGPP1",DGVAR="DGPT",%ZIS("B")="" D ZIS^DGUTQ G:POP QUIT D START
D CLOSE^DGUTQ
QUIT K %,^UTILITY($J),%DT,%ZIS,DA,DGA,DGA1,DGAD,DGALL,DGCAT,DGED,DGFY,DGG,DGHM,DGI,DGNO,DGNOW,DGPGM,DGPT,DGR,DGS,DGSD,DGT,DGVAR,DGW,DGX,DIC,DIV,E,I,J,K,M,POP,W,X,X1,VAUTD,Y,Z Q
START U IO S X=132 X ^%ZOSF("RM")
EN D NOW^DGPTOTRL Q:'$D(^DG(45.9,DGPT)) S DGI=^(DGPT,0),DGG=$S($D(^DG(45.9,DGPT,"R")):^("R"),1:""),DGS=$S($D(^DG(45.9,DGPT,"C")):^("C"),1:"")
S DGFY=$S($E($P(DGI,U,2),4,5)<10:($E($P(DGI,U,2),1,3)_"0000"),1:($E($P(DGI,U,2),1,3)+1_"0000"))
S Z=$P(DGG,U,4),DGCAT=$S(Z=1:"1 - HEAVY REHABILITATION",Z=2:"2 - SPECIAL CARE",Z=3:"3 - CLINICAL COMPLEX",Z=4:"4 - BEHAVIORAL",Z=5:"5 - PHYSICAL",1:"")
Q:'$D(^DPT(+DGI,0))
I ($E(IOST)="C")!($D(FIRST)) W @IOF
W !?48,">>>>PATIENT ASSESSMENT INSTRUMENT<<<<",!!,"NAME: ",$P(^DPT(+DGI,0),U),?92,"PRINTED: ",DGNOW,!," 1.",$J("SSN: ",32),$P(DGI,U,3)
W ?86,$J("RUG-II GROUP: ",15),$P(DGG,U,2),!," 2.",$J("SEX: ",32),$P(DGI,U,4),?86,$J("ADL SUM: ",15),$P(DGG,U,3)
W !," 3.",$J("YEAR OF BIRTH: ",32),$P(DGI,U,5),?86,$J("CATEGORY: ",15),DGCAT,!," 4.",$J("ASSESSMENT DATE: ",32),$$FMTE^XLFDT($P(DGI,U,2),"5DZ")
W ?86,$J("RUG-II WWUs: ",15) I $P(DGG,U,2) W $S($D(^DG(45.91,+$P(DGG,U,2),"FY",DGFY,0)):$P(^(0),U,2),1:"")
W !," 5.",$J("ASSESSMENT PURPOSE: ",32),$S($P(DGI,U,6)=1:"1 ADMISSION/TRANSFER",$P(DGI,U,6)=2:"2 SEMI-ANNUAL CENSUS",1:"3 CONTRACT NURSING HOME")
W !," 6.",$J("DATE OF ADMISSION/TRANSFER IN: ",32),$$FMTE^XLFDT($P(DGI,U,7),"5DZ")
W ?86,$J("RECORD STATUS: ",15),$S($P(DGS,U)]"":$P(DGS,U),1:"INCOMPLETE")," " W:$P(DGS,U)]"" $P($P(^DD(45.9,80,0),$P(DGS,U)_":",2),";",1)
W !," 7.",$J("MEDICAL CENTER CODE: ",32),$P(DGI,U,8),!," 8.",$J("BED SECTION: ",32),$P(DGI,U,9),$S($P(DGI,U,9)="I":"-INTERMEDIATE MED.",$P(DGI,U,9)="N":"-NURSING HOME CARE",1:"")
I $P(DGI,"^",6)'=3 W ?86,$J("WARD: ",15) I +DGG,$D(^DIC(42,+DGG,0)) W $P(^(0),U,1)
I $P(DGI,"^",6)=3 W ?86,$J("CNH LOCATION: ",15) I +DGG,$D(^FBAAV(+DGG,0)) W $P(^(0),U)
PRT K Y W !!?24,"MEDICAL TREATMENTS",?91,"SELECTED DIAGNOSIS",! S $P(Y,"-",19)="" W ?24,Y S $P(Y,"-",18)="" W ?91,Y K Y
F E=10:1:16 W ! D MT I E<14 S E=E+22 W ?66 D MT S E=E-22
W ?87,"ACTIVITIES OF DAILY LIVING" S E=17,$P(Y,"-",27)="" W ! D MT W ?87,Y
F E=18:1:21 W ! X:E<21 "D MT W ?66 D ADL" I E=21 S E=-1 D ADL S E=21 W ?66 D ADL
W !!?26,"MEDICAL EVENTS",?95,"BEHAVIORS",! K Y S $P(Y,"-",15)="" W ?26,Y K Y S $P(Y,"-",10)="",X1=47 W ?95,Y F E=23:1:28 W ! D MT W ?66 X:E=26 "S E=E+21 D MT S E=E-21" I E<26 S E=E-1 D ADL S E=E+1
W !!?56,"SPECIALIZED SERVICES" K Y S $P(Y,"-",21)="" W !?56,Y,!?17,"REHABILITATION MEDICINE THERAPIES",?86,"CHRONIC RESPIRATORY SUPPORT",! S $P(Y,"-",34)="" W ?17,Y K Y S $P(Y,"-",28)="" W ?86,Y
S E(2)=51 F E=47:1:51 W ! D LEV^DGRUGPP S E(2)=E(2)+1 W ?66 D:E<50 ADL2 W ! D THER^DGRUGPP S E(2)=E(2)+1 I E<49 W ?66 D ADL2
S %=IOSL-6 F I=$Y:1:% W !
W !?26,"*QUESTIONS 21,28,29,30,35,36,37 AND 38 ARE RESERVED FIELDS AND ARE NOT DISPLAYED",! Q
MT W $J(E-1,2),".",$J($P(^DD(45.9,E,0),U),30),": ",$P(DGI,U,E),$S(E'=23&(E'=47):$S($P(DGI,U,E)=1:"> NO",$P(DGI,U,E)=2:"> YES",1:""),$P(DGI,U,E)']"":"",1:"> "_$E($P($P(^DD(45.9,E,0),$P(DGI,U,E)_":",2),";",1),1,24)) Q
ADL W E+21,".",$J($P(^DD(45.9,(E+22),0),U),30),": " W:$P(DGI,U,(E+22))]"" $E($P($P(^DD(45.9,(E+22),0),$P(DGI,U,(E+22))_":",2),";",1),1,27)
Q
ADL1 W ?66,E+36,".",$J($P(^DD(45.9,(E+32),0),U),30),": " Q:$P(DGI,U,(E+32))']"" W:E>26 $E($P($P(^DD(45.9,(E+32),0),$P(DGI,U,(E+32))_":",2),";",1),1,27) I E=26 W $P(DGI,U,E+32),"> ",$S($P(DGI,U,E+32)=1:"NO",1:"YES")
Q
ADL2 W E(2),".",$J($P(^DD(45.9,(E(2)+6),0),U),30),": " Q:$P(DGI,U,(E(2)+6))']"" W:E>47!(E(2)=53) $E($P($P(^DD(45.9,(E(2)+6),0),$P(DGI,U,(E(2)+6))_":",2),";",1),1,27) I E=47&(E(2)'=53) W $P(DGI,U,E(2)+6),"> ",$S($P(DGI,U,E(2)+6)=1:"NO",1:"YES")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGPP1 4059 printed Dec 13, 2024@02:58:30 Page 2
DGRUGPP1 ;ALB/BOK/MLI - PRINT PAI FOR A PATIENT ; 25 FEB 87 12:00
+1 ;;5.3;Registration;**89,173**;Aug 13, 1993
+2 SET DIC="^DG(45.9,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if Y'>0
GOTO QUIT
SET DGPT=+Y
+3 WRITE !!,*7,!!,"THIS REPORT REQUIRES 132 COLUMN OUTPUT"
+4 SET DGPGM="START^DGRUGPP1"
SET DGVAR="DGPT"
SET %ZIS("B")=""
DO ZIS^DGUTQ
if POP
GOTO QUIT
DO START
+5 DO CLOSE^DGUTQ
QUIT KILL %,^UTILITY($JOB),%DT,%ZIS,DA,DGA,DGA1,DGAD,DGALL,DGCAT,DGED,DGFY,DGG,DGHM,DGI,DGNO,DGNOW,DGPGM,DGPT,DGR,DGS,DGSD,DGT,DGVAR,DGW,DGX,DIC,DIV,E,I,J,K,M,POP,W,X,X1,VAUTD,Y,Z
QUIT
START USE IO
SET X=132
XECUTE ^%ZOSF("RM")
EN DO NOW^DGPTOTRL
if '$DATA(^DG(45.9,DGPT))
QUIT
SET DGI=^(DGPT,0)
SET DGG=$SELECT($DATA(^DG(45.9,DGPT,"R")):^("R"),1:"")
SET DGS=$SELECT($DATA(^DG(45.9,DGPT,"C")):^("C"),1:"")
+1 SET DGFY=$SELECT($EXTRACT($PIECE(DGI,U,2),4,5)<10:($EXTRACT($PIECE(DGI,U,2),1,3)_"0000"),1:($EXTRACT($PIECE(DGI,U,2),1,3)+1_"0000"))
+2 SET Z=$PIECE(DGG,U,4)
SET DGCAT=$SELECT(Z=1:"1 - HEAVY REHABILITATION",Z=2:"2 - SPECIAL CARE",Z=3:"3 - CLINICAL COMPLEX",Z=4:"4 - BEHAVIORAL",Z=5:"5 - PHYSICAL",1:"")
+3 if '$DATA(^DPT(+DGI,0))
QUIT
+4 IF ($EXTRACT(IOST)="C")!($DATA(FIRST))
WRITE @IOF
+5 WRITE !?48,">>>>PATIENT ASSESSMENT INSTRUMENT<<<<",!!,"NAME: ",$PIECE(^DPT(+DGI,0),U),?92,"PRINTED: ",DGNOW,!," 1.",$JUSTIFY("SSN: ",32),$PIECE(DGI,U,3)
+6 WRITE ?86,$JUSTIFY("RUG-II GROUP: ",15),$PIECE(DGG,U,2),!," 2.",$JUSTIFY("SEX: ",32),$PIECE(DGI,U,4),?86,$JUSTIFY("ADL SUM: ",15),$PIECE(DGG,U,3)
+7 WRITE !," 3.",$JUSTIFY("YEAR OF BIRTH: ",32),$PIECE(DGI,U,5),?86,$JUSTIFY("CATEGORY: ",15),DGCAT,!," 4.",$JUSTIFY("ASSESSMENT DATE: ",32),$$FMTE^XLFDT($PIECE(DGI,U,2),"5DZ")
+8 WRITE ?86,$JUSTIFY("RUG-II WWUs: ",15)
IF $PIECE(DGG,U,2)
WRITE $SELECT($DATA(^DG(45.91,+$PIECE(DGG,U,2),"FY",DGFY,0)):$PIECE(^(0),U,2),1:"")
+9 WRITE !," 5.",$JUSTIFY("ASSESSMENT PURPOSE: ",32),$SELECT($PIECE(DGI,U,6)=1:"1 ADMISSION/TRANSFER",$PIECE(DGI,U,6)=2:"2 SEMI-ANNUAL CENSUS",1:"3 CONTRACT NURSING HOME")
+10 WRITE !," 6.",$JUSTIFY("DATE OF ADMISSION/TRANSFER IN: ",32),$$FMTE^XLFDT($PIECE(DGI,U,7),"5DZ")
+11 WRITE ?86,$JUSTIFY("RECORD STATUS: ",15),$SELECT($PIECE(DGS,U)]"":$PIECE(DGS,U),1:"INCOMPLETE")," "
if $PIECE(DGS,U)]""
WRITE $PIECE($PIECE(^DD(45.9,80,0),$PIECE(DGS,U)_":",2),";",1)
+12 WRITE !," 7.",$JUSTIFY("MEDICAL CENTER CODE: ",32),$PIECE(DGI,U,8),!," 8.",$JUSTIFY("BED SECTION: ",32),$PIECE(DGI,U,9),$SELECT($PIECE(DGI,U,9)="I":"-INTERMEDIATE MED.",$PIECE(DGI,U,9)="N":"-NURSING HOME CARE",1:"")
+13 IF $PIECE(DGI,"^",6)'=3
WRITE ?86,$JUSTIFY("WARD: ",15)
IF +DGG
IF $DATA(^DIC(42,+DGG,0))
WRITE $PIECE(^(0),U,1)
+14 IF $PIECE(DGI,"^",6)=3
WRITE ?86,$JUSTIFY("CNH LOCATION: ",15)
IF +DGG
IF $DATA(^FBAAV(+DGG,0))
WRITE $PIECE(^(0),U)
PRT KILL Y
WRITE !!?24,"MEDICAL TREATMENTS",?91,"SELECTED DIAGNOSIS",!
SET $PIECE(Y,"-",19)=""
WRITE ?24,Y
SET $PIECE(Y,"-",18)=""
WRITE ?91,Y
KILL Y
+1 FOR E=10:1:16
WRITE !
DO MT
IF E<14
SET E=E+22
WRITE ?66
DO MT
SET E=E-22
+2 WRITE ?87,"ACTIVITIES OF DAILY LIVING"
SET E=17
SET $PIECE(Y,"-",27)=""
WRITE !
DO MT
WRITE ?87,Y
+3 FOR E=18:1:21
WRITE !
if E<21
XECUTE "D MT W ?66 D ADL"
IF E=21
SET E=-1
DO ADL
SET E=21
WRITE ?66
DO ADL
+4 WRITE !!?26,"MEDICAL EVENTS",?95,"BEHAVIORS",!
KILL Y
SET $PIECE(Y,"-",15)=""
WRITE ?26,Y
KILL Y
SET $PIECE(Y,"-",10)=""
SET X1=47
WRITE ?95,Y
FOR E=23:1:28
WRITE !
DO MT
WRITE ?66
if E=26
XECUTE "S E=E+21 D MT S E=E-21"
IF E<26
SET E=E-1
DO ADL
SET E=E+1
+5 WRITE !!?56,"SPECIALIZED SERVICES"
KILL Y
SET $PIECE(Y,"-",21)=""
WRITE !?56,Y,!?17,"REHABILITATION MEDICINE THERAPIES",?86,"CHRONIC RESPIRATORY SUPPORT",!
SET $PIECE(Y,"-",34)=""
WRITE ?17,Y
KILL Y
SET $PIECE(Y,"-",28)=""
WRITE ?86,Y
+6 SET E(2)=51
FOR E=47:1:51
WRITE !
DO LEV^DGRUGPP
SET E(2)=E(2)+1
WRITE ?66
if E<50
DO ADL2
WRITE !
DO THER^DGRUGPP
SET E(2)=E(2)+1
IF E<49
WRITE ?66
DO ADL2
+7 SET %=IOSL-6
FOR I=$Y:1:%
WRITE !
+8 WRITE !?26,"*QUESTIONS 21,28,29,30,35,36,37 AND 38 ARE RESERVED FIELDS AND ARE NOT DISPLAYED",!
QUIT
MT WRITE $JUSTIFY(E-1,2),".",$JUSTIFY($PIECE(^DD(45.9,E,0),U),30),": ",$PIECE(DGI,U,E),$SELECT(E'=23&(E'=47):$SELECT($PIECE(DGI,U,E)=1:"> NO",$PIECE(DGI,U,E)=2:"> YES",1:""),...
... $PIECE(DGI,U,E)']"":"",1:"> "_$EXTRACT($PIECE($PIECE(^DD(45.9,E,0),$PIECE(DGI,U,E)_":",2),";",1),1,24))
QUIT
ADL WRITE E+21,".",$JUSTIFY($PIECE(^DD(45.9,(E+22),0),U),30),": "
if $PIECE(DGI,U,(E+22))]""
WRITE $EXTRACT($PIECE($PIECE(^DD(45.9,(E+22),0),$PIECE(DGI,U,(E+22))_":",2),";",1),1,27)
+1 QUIT
ADL1 WRITE ?66,E+36,".",$JUSTIFY($PIECE(^DD(45.9,(E+32),0),U),30),": "
if $PIECE(DGI,U,(E+32))']""
QUIT
if E>26
WRITE $EXTRACT($PIECE($PIECE(^DD(45.9,(E+32),0),$PIECE(DGI,U,(E+32))_":",2),";",1),1,27)
IF E=26
WRITE $PIECE(DGI,U,E+32),"> ",$SELECT($PIECE(DGI,U,E+32)=1:"NO",1:"YES")
+1 QUIT
ADL2 WRITE E(2),".",$JUSTIFY($PIECE(^DD(45.9,(E(2)+6),0),U),30),": "
if $PIECE(DGI,U,(E(2)+6))']""
QUIT
if E>47!(E(2)=53)
WRITE $EXTRACT($PIECE($PIECE(^DD(45.9,(E(2)+6),0),$PIECE(DGI,U,(E(2)+6))_":",2),";",1),1,27)
IF E=47&(E(2)'=53)
WRITE $PIECE(DGI,U,E(2)+6),"> ",$SELECT($PIECE(DGI,U,E(2)+6)=1:"NO",1:"YES")
+1 QUIT
