SDPPMT1 ;ALB/CAW - Patient Profile - Means Test ; 5/14/92
;;5.3;Scheduling;**6,32**;Aug 13, 1993
;
;
EN1 ; Gather Means Test Info
N SDM1,SDMT,SDMT1,SDYN,SDM2,SDSTART,SDSTOP
S (SDM2,SDX)=0,SDFST=20,SDSEC=60,SDLEN=20,$P(SDASH,"-",IOM+1)="",SDDT=SDED_.99,SDSTART=$S($D(SDBEG):SDBEG,1:SDBD),SDSTOP=$S($D(SDEND):SDEND,1:SDED)
I $D(SDY) S SDDT=$P(^DGMT(408.31,SDY,0),U)
F S SDX=$$LST^DGMTU(DFN,SDDT) Q:SDX']"" S SDDT=$P(SDX,U,2) Q:'$D(SDY)&(SDDT>SDED!(SDDT<SDBD)) D INIT Q:(SDPRINT)!$D(SDY) S SDDT=SDDT-1
Q
;
INIT ; Set up means test variables
D ALL^DGMTU21(DFN,"VSC",SDDT,"IPR")
I $D(DGINR("V")) S SDMT=$G(^DGMT(408.22,+DGINR("V"),0))
I $D(DGINR("V")) S SDM1=$G(^DGMT(408.21,+DGINC("V"),0))
S SDMT1=$G(^DGMT(408.31,+SDX,0))
D INFO
Q
INFO ;
;
DATE ; Date of Test and Status
S X="",X=$$SETSTR^VALM1("Date of Test:",X,6,13)
S X=$$SETSTR^VALM1($$FTIME^VALM1(+SDMT1),X,SDFST,SDLEN)
S X=$$SETSTR^VALM1("Status:",X,52,7)
S X=$$SETSTR^VALM1($P($G(^DG(408.32,+$P(SDMT1,U,3),0)),U),X,SDSEC,SDLEN)
D SET(X)
NET ; Net Worth and Income
S X="",X=$$SETSTR^VALM1("Net Worth:",X,9,10)
S X=$$SETSTR^VALM1($P(SDMT1,U,5),X,SDFST,SDLEN)
S X=$$SETSTR^VALM1("Income:",X,52,7)
S X=$$SETSTR^VALM1($P(SDMT1,U,4),X,SDSEC,SDLEN)
D SET(X)
DATEC ; Date Completed and Deductible Expenses
S X="",X=$$SETSTR^VALM1("Date Completed:",X,4,15)
I $P(SDMT1,U,7)'="" S X=$$SETSTR^VALM1($$FTIME^VALM1($P(SDMT1,U,7)),X,SDFST,SDLEN)
S X=$$SETSTR^VALM1("Deductible Exp.:",X,43,16)
S X=$$SETSTR^VALM1($P(SDMT1,U,15),X,SDSEC,SDLEN)
D SET(X)
COMP ; Completed By and Agreed to Pay Deductible
S X="",X=$$SETSTR^VALM1("Completed By:",X,6,13)
S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(SDMT1,U,6),0)),U),X,SDFST,SDLEN)
S SDYN=$S($P(SDMT1,U,11)=1:"YES",$P(SDMT1,U,11)=0:"NO",1:"UNKNOWN")
S X=$$SETSTR^VALM1("Will Pay Deduct.:",X,42,17)
S X=$$SETSTR^VALM1(SDYN,X,SDSEC,SDLEN)
D SET(X)
DEC ; Declined to Give Income Info and Date Category Changed
S X=""
I $P(SDMT1,U,14)'="" D
.S X=$$SETSTR^VALM1("Decl To Give Info:",X,1,18)
.S SDYN=$S($P(SDMT1,U,14)=1:"YES",$P(SDMT1,U,14)=0:"NO",1:"UNKNOWN")
.S X=$$SETSTR^VALM1(SDYN,X,SDFST,SDLEN)
I $P(SDMT1,U,9)'="" D
.S X=$$SETSTR^VALM1("Date Cat. Changed:",X,41,18)
.S X=$$SETSTR^VALM1($$FTIME^VALM1($P(SDMT1,U,9)),X,SDSEC,SDLEN)
D:X'="" SET(X)
NO ; No Longer Required Date and Category Changed By
S X=""
I $P(SDMT1,U,17)'="" D
.S X=$$SETSTR^VALM1("No Lon. Req. Date:",X,1,18)
.S X=$$SETSTR^VALM1($$FTIME^VALM1($P(SDMT1,U,17)),X,SDFST,SDLEN)
I $P(SDMT1,U,8)'="" D
.S X=$$SETSTR^VALM1("Cat. Changed By:",X,43,16)
.S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(SDMT1,U,8),0)),U),X,SDSEC,SDLEN)
D:X'="" SET(X)
D ^SDPPMT2
Q
SET(X) ; Set in ^TMP global for display
;
S SDLN=SDLN+1,^TMP("SDPPALL",$J,SDLN,0)=X
Q
QUIT ;
K SDASH,SDFST,SDLEN,SDM,SDM1,SDMT,SDMT1,SDSEC,SDX,SDY,SDYN,^TMP("SDPPENR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPPMT1 2898 printed Oct 16, 2024@19:00:11 Page 2
SDPPMT1 ;ALB/CAW - Patient Profile - Means Test ; 5/14/92
+1 ;;5.3;Scheduling;**6,32**;Aug 13, 1993
+2 ;
+3 ;
EN1 ; Gather Means Test Info
+1 NEW SDM1,SDMT,SDMT1,SDYN,SDM2,SDSTART,SDSTOP
+2 SET (SDM2,SDX)=0
SET SDFST=20
SET SDSEC=60
SET SDLEN=20
SET $PIECE(SDASH,"-",IOM+1)=""
SET SDDT=SDED_.99
SET SDSTART=$SELECT($DATA(SDBEG):SDBEG,1:SDBD)
SET SDSTOP=$SELECT($DATA(SDEND):SDEND,1:SDED)
+3 IF $DATA(SDY)
SET SDDT=$PIECE(^DGMT(408.31,SDY,0),U)
+4 FOR
SET SDX=$$LST^DGMTU(DFN,SDDT)
if SDX']""
QUIT
SET SDDT=$PIECE(SDX,U,2)
if '$DATA(SDY)&(SDDT>SDED!(SDDT<SDBD))
QUIT
DO INIT
if (SDPRINT)!$DATA(SDY)
QUIT
SET SDDT=SDDT-1
+5 QUIT
+6 ;
INIT ; Set up means test variables
+1 DO ALL^DGMTU21(DFN,"VSC",SDDT,"IPR")
+2 IF $DATA(DGINR("V"))
SET SDMT=$GET(^DGMT(408.22,+DGINR("V"),0))
+3 IF $DATA(DGINR("V"))
SET SDM1=$GET(^DGMT(408.21,+DGINC("V"),0))
+4 SET SDMT1=$GET(^DGMT(408.31,+SDX,0))
+5 DO INFO
+6 QUIT
INFO ;
+1 ;
DATE ; Date of Test and Status
+1 SET X=""
SET X=$$SETSTR^VALM1("Date of Test:",X,6,13)
+2 SET X=$$SETSTR^VALM1($$FTIME^VALM1(+SDMT1),X,SDFST,SDLEN)
+3 SET X=$$SETSTR^VALM1("Status:",X,52,7)
+4 SET X=$$SETSTR^VALM1($PIECE($GET(^DG(408.32,+$PIECE(SDMT1,U,3),0)),U),X,SDSEC,SDLEN)
+5 DO SET(X)
NET ; Net Worth and Income
+1 SET X=""
SET X=$$SETSTR^VALM1("Net Worth:",X,9,10)
+2 SET X=$$SETSTR^VALM1($PIECE(SDMT1,U,5),X,SDFST,SDLEN)
+3 SET X=$$SETSTR^VALM1("Income:",X,52,7)
+4 SET X=$$SETSTR^VALM1($PIECE(SDMT1,U,4),X,SDSEC,SDLEN)
+5 DO SET(X)
DATEC ; Date Completed and Deductible Expenses
+1 SET X=""
SET X=$$SETSTR^VALM1("Date Completed:",X,4,15)
+2 IF $PIECE(SDMT1,U,7)'=""
SET X=$$SETSTR^VALM1($$FTIME^VALM1($PIECE(SDMT1,U,7)),X,SDFST,SDLEN)
+3 SET X=$$SETSTR^VALM1("Deductible Exp.:",X,43,16)
+4 SET X=$$SETSTR^VALM1($PIECE(SDMT1,U,15),X,SDSEC,SDLEN)
+5 DO SET(X)
COMP ; Completed By and Agreed to Pay Deductible
+1 SET X=""
SET X=$$SETSTR^VALM1("Completed By:",X,6,13)
+2 SET X=$$SETSTR^VALM1($PIECE($GET(^VA(200,+$PIECE(SDMT1,U,6),0)),U),X,SDFST,SDLEN)
+3 SET SDYN=$SELECT($PIECE(SDMT1,U,11)=1:"YES",$PIECE(SDMT1,U,11)=0:"NO",1:"UNKNOWN")
+4 SET X=$$SETSTR^VALM1("Will Pay Deduct.:",X,42,17)
+5 SET X=$$SETSTR^VALM1(SDYN,X,SDSEC,SDLEN)
+6 DO SET(X)
DEC ; Declined to Give Income Info and Date Category Changed
+1 SET X=""
+2 IF $PIECE(SDMT1,U,14)'=""
Begin DoDot:1
+3 SET X=$$SETSTR^VALM1("Decl To Give Info:",X,1,18)
+4 SET SDYN=$SELECT($PIECE(SDMT1,U,14)=1:"YES",$PIECE(SDMT1,U,14)=0:"NO",1:"UNKNOWN")
+5 SET X=$$SETSTR^VALM1(SDYN,X,SDFST,SDLEN)
End DoDot:1
+6 IF $PIECE(SDMT1,U,9)'=""
Begin DoDot:1
+7 SET X=$$SETSTR^VALM1("Date Cat. Changed:",X,41,18)
+8 SET X=$$SETSTR^VALM1($$FTIME^VALM1($PIECE(SDMT1,U,9)),X,SDSEC,SDLEN)
End DoDot:1
+9 if X'=""
DO SET(X)
NO ; No Longer Required Date and Category Changed By
+1 SET X=""
+2 IF $PIECE(SDMT1,U,17)'=""
Begin DoDot:1
+3 SET X=$$SETSTR^VALM1("No Lon. Req. Date:",X,1,18)
+4 SET X=$$SETSTR^VALM1($$FTIME^VALM1($PIECE(SDMT1,U,17)),X,SDFST,SDLEN)
End DoDot:1
+5 IF $PIECE(SDMT1,U,8)'=""
Begin DoDot:1
+6 SET X=$$SETSTR^VALM1("Cat. Changed By:",X,43,16)
+7 SET X=$$SETSTR^VALM1($PIECE($GET(^VA(200,+$PIECE(SDMT1,U,8),0)),U),X,SDSEC,SDLEN)
End DoDot:1
+8 if X'=""
DO SET(X)
+9 DO ^SDPPMT2
+10 QUIT
SET(X) ; Set in ^TMP global for display
+1 ;
+2 SET SDLN=SDLN+1
SET ^TMP("SDPPALL",$JOB,SDLN,0)=X
+3 QUIT
QUIT ;
+1 KILL SDASH,SDFST,SDLEN,SDM,SDM1,SDMT,SDMT1,SDSEC,SDX,SDY,SDYN,^TMP("SDPPENR",$JOB)
+2 QUIT
