- 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 Feb 19, 2025@00:24:32 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