- DGRUGPI ;ALB/BOK/MLI - PRINT PATIENTS WITH INCOMPLETE PAIs ; 15 MAR 87
- ;;5.3;Registration;**89,97,1015**;Aug 13, 1993;Build 21
- D QUIT D ASK2^SDDIV G:Y<0 QUIT
- N ERR S ERR=$$CHOSE^DGRUGU1()
- I +ERR<0 G QUIT
- S SEL=$P(ERR,"^",2)
- W !!,"**** Date Range Selection ****"
- DATE S %DT("A")="START DATE: ",%DT="AEPX" D ^%DT G:Y<0 QUIT S DGBDT=Y-.1
- S %DT("A")=" END DATE: ",%DT(0)=Y D ^%DT G:Y<0 QUIT S DGEDT=Y_.9
- S DGVAR="SEL^DGBDT^DGEDT^DGW#^VAUTD#^DGCL#",DGPGM="START^DGRUGPI" D ZIS^DGUTQ G:POP QUIT D START,CLOSE^DGUTQ Q
- ;
- START W:$E(IOST?1"C-") @IOF
- S DGFFL=0 K %DT S X="N",%DT="R" D ^%DT S DGNOW=+Y K X,Y,%DT U IO I '$D(^DG(45.9,"AS",5)) G NOINC
- S DGFL=1,DGFL2=0,PAGE=1
- F I=0:0 S I=$O(^DG(45.9,"AS",5,I)) Q:+I'>0!(DGFL2) D
- .S DGI=^DG(45.9,I,0)
- .S W=$S($D(^DG(45.9,I,"R")):$P(^("R"),U),1:0)
- .S DGAD=$P($P(DGI,U,2),".")
- .S DGTYPE=$P(DGI,U,6) ;assessment purpose
- .I DGAD>DGBDT&(DGAD<DGEDT) D SET Q:DGFL2
- G:'$D(^UTILITY($J)) NOINC
- G:DGFL2 QUIT
- S W=""
- F Q:DGFL2 D:$E(IOST)="C"&(DGFFL) PAGEND Q:DGFL2 S DGFFL=1 S W=$O(^UTILITY($J,"NOP",W)) Q:(DGFL2)!(W="")!(+W'?.N) D
- .S FIRST=1
- .F I=0:0 S I=$O(^UTILITY($J,"NOP",+W,I)) Q:+I'>0!(DGFL2) D
- ..F D=0:0 S D=$O(^UTILITY($J,"NOP",+W,+I,D)) Q:+D'>0!(DGFL2) D
- ...S DGI=$G(^UTILITY($J,"NOP",W,I,D))
- ...I FIRST D HEAD S FIRST=0
- ...D PRT
- G:DGFL2 QUIT
- QUIT W ! K %DT,^UTILITY($J),D,DFN,DGAD,DGBDT,DGEDT,DGFFL,DGFL,DGFL2,DGI,DGNOW
- K DGPGM,DGVAR,DGW,DIV,E,I,POP,W,X,Y,DGCL,VAUTD,PAGE,DGTYPE,FIRST
- Q
- ;
- SET Q:'$D(DGW)&('$D(DGCL))
- I DGTYPE'=3 I SEL="B"!(SEL="R") I 'VAUTD S DIV=+$S(+$P($G(^DIC(42,+W,0)),U,11):$P(^(0),U,11),1:$O(^DG(40.8,0))) I '$D(VAUTD(+DIV)) Q
- I DGTYPE=3 S DIV=0
- I SEL="C" Q:'$D(DGCL(+W))&(DGCL'=1) I (DGTYPE=3) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
- I SEL="R" Q:'$D(DGW(+W))&(DGW'=1) I (DGTYPE'=3) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
- I SEL="B" S:W="" W=0 D
- .I DGTYPE=3 I DGCL=1!($D(DGCL(+W))) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
- .I DGTYPE'=3 I DGW=1!($D(DGW(+W))) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
- Q
- ;
- PRT I $Y'<(IOSL-2) D PAGEND:$E(IOST)="C" Q:DGFL2 D HEAD
- Q:DGFL2
- S DFN=+DGI W !,$E($P(^DPT(+DGI,0),U),1,25),?27,$P(DGI,U,3),?42 S Y=$P($P(DGI,U,7),".") D DT^DIQ W ?62,$S($P(DGI,U,6)=1:"ADMISSION/TRANSFER",$P(DGI,U,6)=2:"SEMI-ANNUAL CENSUS",$P(DGI,U,6)=3:"CONTRACT NURSING HOME")
- Q
- HEAD I PAGE>1!($E(IOST)="C") W @IOF
- S PAGE=PAGE+1
- W !!?20,"INCOMPLETE PATIENT ASSESSMENT INSTRUMENTS"
- W !?20 D DATES
- I '+W D NOWD
- I $P(DGI,"^",6)'=3 W !!,$P($G(^DIC(42,+W,0)),U)
- I $P(DGI,"^",6)=3 W !!,$P($G(^FBAAV(+W,0)),U)
- W !!?45,"DATE OF",?66,"ASSESSMENT",!,"NAME",?30,"SSN",?40,"ADMISSION/TRANSFER",?68,"PURPOSE"
- K E S $P(E,"=",81)="" W !,E
- Q
- NOWD W !!,"No location listed in Patient Assessment File for:" S DGFL=0 Q
- PAGEND W !,?29,"HIT <RETURN> TO CONTINUE" R X:DTIME S:X["^"!('$T) DGFL2=1 S DGFL=1 Q:X[""
- Q:DGFL2
- G PAGEND
- NOINC W @IOF,!!,"INCOMPLETE PATIENT ASSESSMENTS",!!!!,"THERE ARE NO PATIENTS WITH THE STATUS OF INCOMPLETE" W ! D DATES,LOC G QUIT
- DATES W !?20,"FOR DATE RANGE: " S Y=DGBDT+.1 D DT^DIQ W "-" S Y=DGEDT-.9 D DT^DIQ W !?20," DATE PRINTED: " S Y=DGNOW D DT^DIQ
- Q
- LOC ;
- N CNT
- W !!?10,"FOR LOCATIONS: "
- I $D(DGCL),DGCL=1 W "ALL Contract Nursing Homes "
- I $D(DGW),DGW=1 W "ALL Wards"
- I $D(DGCL),DGCL'=1 D
- .S CNT=0
- .F S CNT=$O(DGCL(CNT)) Q:CNT="" D
- ..W !?20,$P($G(DGCL(CNT)),"^")
- I $D(DGW),DGW'=1 D
- .S CNT=0
- .F S CNT=$O(DGW(CNT)) Q:CNT="" D
- ..W !?20,$P($G(DGW(CNT)),"^")
- Q
- DGRUGPI ;ALB/BOK/MLI - PRINT PATIENTS WITH INCOMPLETE PAIs ; 15 MAR 87
- +1 ;;5.3;Registration;**89,97,1015**;Aug 13, 1993;Build 21
- +2 DO QUIT
- DO ASK2^SDDIV
- IF Y<0
- GOTO QUIT
- +3 NEW ERR
- SET ERR=$$CHOSE^DGRUGU1()
- +4 IF +ERR<0
- GOTO QUIT
- +5 SET SEL=$PIECE(ERR,"^",2)
- +6 WRITE !!,"**** Date Range Selection ****"
- DATE SET %DT("A")="START DATE: "
- SET %DT="AEPX"
- DO ^%DT
- IF Y<0
- GOTO QUIT
- SET DGBDT=Y-.1
- +1 SET %DT("A")=" END DATE: "
- SET %DT(0)=Y
- DO ^%DT
- IF Y<0
- GOTO QUIT
- SET DGEDT=Y_.9
- +2 SET DGVAR="SEL^DGBDT^DGEDT^DGW#^VAUTD#^DGCL#"
- SET DGPGM="START^DGRUGPI"
- DO ZIS^DGUTQ
- IF POP
- GOTO QUIT
- DO START
- DO CLOSE^DGUTQ
- QUIT
- +3 ;
- START IF $EXTRACT(IOST?1"C-")
- WRITE @IOF
- +1 SET DGFFL=0
- KILL %DT
- SET X="N"
- SET %DT="R"
- DO ^%DT
- SET DGNOW=+Y
- KILL X,Y,%DT
- USE IO
- IF '$DATA(^DG(45.9,"AS",5))
- GOTO NOINC
- +2 SET DGFL=1
- SET DGFL2=0
- SET PAGE=1
- +3 FOR I=0:0
- SET I=$ORDER(^DG(45.9,"AS",5,I))
- IF +I'>0!(DGFL2)
- QUIT
- Begin DoDot:1
- +4 SET DGI=^DG(45.9,I,0)
- +5 SET W=$SELECT($DATA(^DG(45.9,I,"R")):$PIECE(^("R"),U),1:0)
- +6 SET DGAD=$PIECE($PIECE(DGI,U,2),".")
- +7 ;assessment purpose
- SET DGTYPE=$PIECE(DGI,U,6)
- +8 IF DGAD>DGBDT&(DGAD<DGEDT)
- DO SET
- IF DGFL2
- QUIT
- End DoDot:1
- +9 IF '$DATA(^UTILITY($JOB))
- GOTO NOINC
- +10 IF DGFL2
- GOTO QUIT
- +11 SET W=""
- +12 FOR
- IF DGFL2
- QUIT
- IF $EXTRACT(IOST)="C"&(DGFFL)
- DO PAGEND
- IF DGFL2
- QUIT
- SET DGFFL=1
- SET W=$ORDER(^UTILITY($JOB,"NOP",W))
- IF (DGFL2)!(W="")!(+W'?.N)
- QUIT
- Begin DoDot:1
- +13 SET FIRST=1
- +14 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"NOP",+W,I))
- IF +I'>0!(DGFL2)
- QUIT
- Begin DoDot:2
- +15 FOR D=0:0
- SET D=$ORDER(^UTILITY($JOB,"NOP",+W,+I,D))
- IF +D'>0!(DGFL2)
- QUIT
- Begin DoDot:3
- +16 SET DGI=$GET(^UTILITY($JOB,"NOP",W,I,D))
- +17 IF FIRST
- DO HEAD
- SET FIRST=0
- +18 DO PRT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 IF DGFL2
- GOTO QUIT
- QUIT WRITE !
- KILL %DT,^UTILITY($JOB),D,DFN,DGAD,DGBDT,DGEDT,DGFFL,DGFL,DGFL2,DGI,DGNOW
- +1 KILL DGPGM,DGVAR,DGW,DIV,E,I,POP,W,X,Y,DGCL,VAUTD,PAGE,DGTYPE,FIRST
- +2 QUIT
- +3 ;
- SET IF '$DATA(DGW)&('$DATA(DGCL))
- QUIT
- +1 IF DGTYPE'=3
- IF SEL="B"!(SEL="R")
- IF 'VAUTD
- SET DIV=+$SELECT(+$PIECE($GET(^DIC(42,+W,0)),U,11):$PIECE(^(0),U,11),1:$ORDER(^DG(40.8,0)))
- IF '$DATA(VAUTD(+DIV))
- QUIT
- +2 IF DGTYPE=3
- SET DIV=0
- +3 IF SEL="C"
- IF '$DATA(DGCL(+W))&(DGCL'=1)
- QUIT
- IF (DGTYPE=3)
- SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
- +4 IF SEL="R"
- IF '$DATA(DGW(+W))&(DGW'=1)
- QUIT
- IF (DGTYPE'=3)
- SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
- +5 IF SEL="B"
- IF W=""
- SET W=0
- Begin DoDot:1
- +6 IF DGTYPE=3
- IF DGCL=1!($DATA(DGCL(+W)))
- SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
- +7 IF DGTYPE'=3
- IF DGW=1!($DATA(DGW(+W)))
- SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
- End DoDot:1
- +8 QUIT
- +9 ;
- PRT IF $Y'<(IOSL-2)
- IF $EXTRACT(IOST)="C"
- DO PAGEND
- IF DGFL2
- QUIT
- DO HEAD
- +1 IF DGFL2
- QUIT
- +2 SET DFN=+DGI
- WRITE !,$EXTRACT($PIECE(^DPT(+DGI,0),U),1,25),?27,$PIECE(DGI,U,3),?42
- SET Y=$PIECE($PIECE(DGI,U,7),".")
- DO DT^DIQ
- WRITE ?62,$SELECT($PIECE(DGI,U,6)=1:"ADMISSION/TRANSFER",$PIECE(DGI,U,6)=2:"SEMI-ANNUAL CENSUS",$PIECE(DGI,U,6)=3:"CONTRACT NURSING HOME")
- +3 QUIT
- HEAD IF PAGE>1!($EXTRACT(IOST)="C")
- WRITE @IOF
- +1 SET PAGE=PAGE+1
- +2 WRITE !!?20,"INCOMPLETE PATIENT ASSESSMENT INSTRUMENTS"
- +3 WRITE !?20
- DO DATES
- +4 IF '+W
- DO NOWD
- +5 IF $PIECE(DGI,"^",6)'=3
- WRITE !!,$PIECE($GET(^DIC(42,+W,0)),U)
- +6 IF $PIECE(DGI,"^",6)=3
- WRITE !!,$PIECE($GET(^FBAAV(+W,0)),U)
- +7 WRITE !!?45,"DATE OF",?66,"ASSESSMENT",!,"NAME",?30,"SSN",?40,"ADMISSION/TRANSFER",?68,"PURPOSE"
- +8 KILL E
- SET $PIECE(E,"=",81)=""
- WRITE !,E
- +9 QUIT
- NOWD WRITE !!,"No location listed in Patient Assessment File for:"
- SET DGFL=0
- QUIT
- PAGEND WRITE !,?29,"HIT <RETURN> TO CONTINUE"
- READ X:DTIME
- IF X["^"!('$TEST)
- SET DGFL2=1
- SET DGFL=1
- IF X[""
- QUIT
- +1 IF DGFL2
- QUIT
- +2 GOTO PAGEND
- NOINC WRITE @IOF,!!,"INCOMPLETE PATIENT ASSESSMENTS",!!!!,"THERE ARE NO PATIENTS WITH THE STATUS OF INCOMPLETE"
- WRITE !
- DO DATES
- DO LOC
- GOTO QUIT
- DATES WRITE !?20,"FOR DATE RANGE: "
- SET Y=DGBDT+.1
- DO DT^DIQ
- WRITE "-"
- SET Y=DGEDT-.9
- DO DT^DIQ
- WRITE !?20," DATE PRINTED: "
- SET Y=DGNOW
- DO DT^DIQ
- +1 QUIT
- LOC ;
- +1 NEW CNT
- +2 WRITE !!?10,"FOR LOCATIONS: "
- +3 IF $DATA(DGCL)
- IF DGCL=1
- WRITE "ALL Contract Nursing Homes "
- +4 IF $DATA(DGW)
- IF DGW=1
- WRITE "ALL Wards"
- +5 IF $DATA(DGCL)
- IF DGCL'=1
- Begin DoDot:1
- +6 SET CNT=0
- +7 FOR
- SET CNT=$ORDER(DGCL(CNT))
- IF CNT=""
- QUIT
- Begin DoDot:2
- +8 WRITE !?20,$PIECE($GET(DGCL(CNT)),"^")
- End DoDot:2
- End DoDot:1
- +9 IF $DATA(DGW)
- IF DGW'=1
- Begin DoDot:1
- +10 SET CNT=0
- +11 FOR
- SET CNT=$ORDER(DGW(CNT))
- IF CNT=""
- QUIT
- Begin DoDot:2
- +12 WRITE !?20,$PIECE($GET(DGW(CNT)),"^")
- End DoDot:2
- End DoDot:1
- +13 QUIT
