DGMTUTL ;ALB/CAW/BRM/LBD - Means Test generic utilities ; 8/12/02 4:33pm
;;5.3;Registration;**3,31,166,182,454,688**;Aug 13, 1993;Build 29
;
FDATE(Y) ; -- return formatted date
; input: Y := field name
; output: [returned] := formatted date only
N DGY
S DGY=$$FMTE^XLFDT(Y,"5F"),DGY=$TR(DGY," ","0")
Q DGY
;
FTIME(Y) ; -- return formatted date/time
; input: Y := internal date/time
; output: [returned] := formatted date and time
D DD^%DT
Q Y
;
RANGE(WHEN) ; select date range
; input: WHEN := past or future dates (optional)
; output: DGBEG := begin date
; DGEND := end date
; return: was selection made [ 1|yes 0|no]
W !!,$$LINE("Date Range Selection")
DATE S DIR(0)="D^::EX",DIR("A")="Enter Beginning Date",DIR("?")="^D HELP^%DTC" D ^DIR K DIR G:$D(DIRUT) RANGEQ S DGBEG=Y
I $G(WHEN)="P",DGBEG>(DT_.9999) W !," Future dates are not allowed.",*7 K DGBEG G DATE
I $G(WHEN)="F",(DGBEG_.9999)<DT W !," Past dates are not allowed.",*7 K DGBEG G DATE
;select ending date
S DIR(0)="D^::EX",DIR("A")="Enter Ending Date",DIR("?")="^D HELP^%DTC" D ^DIR K DIR G:$D(DIRUT) RANGEQ
S DGEND=Y
I $G(WHEN)="P",DGEND>(DT_.9999) W !," Future dates are not allowed.",*7 K DGEND G DATE
I $G(WHEN)="F",(DGEND_.9999)<DT W !," Past dates are not allowed.",*7 K DGEND G DATE
I DGEND<DGBEG W !!,"Beginning Date must be prior to Ending Date" K DGEND G DATE
RANGEQ Q $D(DGEND)
;
DIV() ; -- get division data
; input: none
; output: VAUTD := divs selected (VAUTD=1 for all)
; return: was selection made [ 1|yes 0|no]
;
W:$P($G(^DG(43,1,"GL")),U,2) !!,$$LINE("Division Selection")
D ASK2 I Y<0 K VAUTD
Q $D(VAUTD)>0
;
CLINIC() ; -- get clinic data
; input: VAUTD := divisions selected
; output: VAUTC := clinic selected (VAUTC=1 for all)
; return: was selection made [ 1|yes 0|no]
;
W !!,$$LINE("Clinic Selection")
S DIC("S")="I $S(VAUTD:1,$D(VAUTD(+$P(^SC(Y,0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
S DIC="^SC(",VAUTSTR="clinic",VAUTVB="VAUTC",VAUTNI=2
D FIRST^VAUTOMA
I Y<0 K VAUTC
CLINICQ Q $D(VAUTC)>0
;
;
LINE(STR) ; -- print line
; input: STR := text to insert
; output: none
; return: text to use
;
N X
S:STR]"" STR=" "_STR_" "
S $P(X,"_",(IOM/2)-($L(STR)/2))=""
Q X_STR_X
;
ASK2 S (VAUTD,Y)=0 I '$D(^DG(40.8,+$O(^DG(40.8,0)),0)) W !,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP" G ASK2Q
I '$P($G(^DG(43,1,"GL")),U,2) S VAUTD=1 G ASK2Q
I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) G DIVISION^VAUTOMA
S I=$O(^DG(40.8,0)) G:'$D(^DG(40.8,+I,0)) ASK2Q S VAUTD(I)=$P(^(0),U) K DIC Q
ASK2Q ;
Q
;
CLOSE ; Utility to clean up tasked outputs
Q:'$D(ZTQUEUED)
D KILL^%ZTLOAD K ZTSK,ZTDESC,ZTRTN,ZTREQ,ZTSAVE,ZTIO,ZTDTH,ZTUCI,IO("Q"),IO("C")
Q
;
XMY(GROUP,DGDUZ,DGPOST) ; -- set up XMY for mail group members
; input: GROUP := mail group efn [required]
; DGDUZ := send to current user [ 0|no ; 1|yes] [optional]
; DGPOST := send to postmaster if XMY is undefined
; [ 0|no ; 1|yes] [optional]
; output: XMY := array of users
; XMDUZ := message sender set postmaster
;
N I K XMY
I '$D(DGDUZ) N DGDUZ S DGDUZ=1
I '$D(DGPOST) N DGPOST S SDPOST=1
S XMY("G."_$P($G(^XMB(3.8,GROUP,0)),U))=""
I DGDUZ,DUZ S XMY(DUZ)=""
; makes sure it gets sent to someone
I '$D(XMY),DGPOST S XMY(.5)=""
; make postmaster the sender so it will show up as new to DUZ
S XMDUZ=.5
Q
;
;
LOCK(DFN) ;
; Description: Sets a lock used to synchronize local income test
; options with the income test upload.
;
; Input:
; DFN - ien of record in PATIENT file
;
; Output:
; Function value - returns 1 if the lock was obtained, 0 otherwise.
;
Q:'$G(DFN) 1
L +^DGMT("LOCAL INCOME TEST",DFN):5
Q $T
;
;
UNLOCK(DFN) ;
; Description: Release the lock obtained by calling $$LOCK(DFN).
;
; Input:
; DFN - ien of record in PATIENT file
;
; Output: none
;
Q:'$G(DFN)
L -^DGMT("LOCAL INCOME TEST",DFN)
Q
;
PA(DGMTI) ;Determine if the Pending Adjudication is for MT or GMT
; Input:
; DGMTI - IEN of Annual Means Test file #408.31
; Output:
; Returns "MT","GMT", or "" if it can't be determined
;
N PA,DGMT0,MTTHR,GMTTHR
S PA=""
I '$G(DGMTI) Q PA
S DGMT0=$G(^DGMT(408.31,DGMTI,0))
; If means test status is not Pending Adjudication, quit
I $P(DGMT0,U,3)'=2 Q PA
; Get MT Threshold and GMT Threshold
S MTTHR=+$P(DGMT0,U,12) I 'MTTHR Q PA
S GMTTHR=+$P(DGMT0,U,27)
; If GMT Threshold is greater than MT Threshold then return GMT,
; otherwise return MT
S PA=$S(GMTTHR>MTTHR:"GMT",1:"MT")
Q PA
;
ISCNVRT(DGINC) ;* Convert Node 0 for records in 408.21 (IAI)
; Input: DGINC - Individual Annual Income IEN Array
;
N RESULT,IAIREC,NULLVAL,PCE,IAIIEN,TOT08,TOT201,TOT204,NWNODE
S NULLVAL=""
;
; Convert 408.21 nodes to version 1 form
F RECTYP="V","S","D" DO
. I RECTYP'="D" DO
. . I $D(DGINC(RECTYP)) DO
. . . S IAIIEN=DGINC(RECTYP)
. . . S IAIREC=$G(^DGMT(408.21,IAIIEN,0))
. . . S NWNODE=$G(^DGMT(408.21,IAIIEN,2))
. . . S (TOT08,TOT201,TOT204)=0
. . . S TOT201=$P(NWNODE,"^",1)+$P(NWNODE,"^",2)
. . . S TOT204=$P(NWNODE,"^",4)-$P(NWNODE,"^",5)
. . . S PCE=""
. . . F PCE=8:1:13,15,16 I $P(IAIREC,"^",PCE)'=NULLVAL S TOT08=TOT08+$P(IAIREC,"^",PCE)
. . . N DGERR,DGMTRT,FLDNM
. . . S FLDNM=""
. . . S DGERR=""
. . . F FLDNM=.09:.01:.13,.15,.16,2.02,2.05 S DGMTRT(408.21,IAIIEN_",",FLDNM)="@"
. . . S DGMTRT(408.21,IAIIEN_",",".08")=$S(TOT08>0:TOT08,1:"")
. . . S DGMTRT(408.21,IAIIEN_",","2.01")=$S(TOT201>0:TOT201,1:"")
. . . S DGMTRT(408.21,IAIIEN_",","2.04")=$S(TOT204>0:TOT204,1:"")
. . . D FILE^DIE("E","DGMTRT",DGERR)
. ;
. I RECTYP="D" DO
. . N DEPNUM,DGMTVR
. . S DGMTVR=1
. . S DEPNUM=""
. . F S DEPNUM=$O(DGINC("D",DEPNUM)) Q:DEPNUM="" DO
. . . S IAIIEN=DGINC("D",DEPNUM)
. . . S IAIREC=$G(^DGMT(408.21,IAIIEN,0))
. . . S NWNODE=$G(^DGMT(408.21,IAIIEN,2))
. . . S (TOT08,TOT201,TOT204)=0
. . . S TOT201=$P(NWNODE,"^",1)+$P(NWNODE,"^",2)
. . . S TOT204=$P(NWNODE,"^",4)-$P(NWNODE,"^",5)
. . . S PCE=""
. . . F PCE=8:1:13,15,16 I $P(IAIREC,"^",PCE)'=NULLVAL S TOT08=TOT08+$P(IAIREC,"^",PCE)
. . . N DGERR,DGMTRT,FLDNM
. . . S FLDNM=""
. . . S DGERR=""
. . . F FLDNM=.09:.01:.13,.15,.16,2.02,2.05 S DGMTRT(408.21,IAIIEN_",",FLDNM)="@"
. . . S DGMTRT(408.21,IAIIEN_",",".08")=$S(TOT08>0:TOT08,1:"")
. . . S DGMTRT(408.21,IAIIEN_",","2.01")=$S(TOT201>0:TOT201,1:"")
. . . S DGMTRT(408.21,IAIIEN_",","2.04")=$S(TOT204>0:TOT204,1:"")
. . . D FILE^DIE("E","DGMTRT",DGERR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTUTL 6694 printed Sep 23, 2025@20:21:34 Page 2
DGMTUTL ;ALB/CAW/BRM/LBD - Means Test generic utilities ; 8/12/02 4:33pm
+1 ;;5.3;Registration;**3,31,166,182,454,688**;Aug 13, 1993;Build 29
+2 ;
FDATE(Y) ; -- return formatted date
+1 ; input: Y := field name
+2 ; output: [returned] := formatted date only
+3 NEW DGY
+4 SET DGY=$$FMTE^XLFDT(Y,"5F")
SET DGY=$TRANSLATE(DGY," ","0")
+5 QUIT DGY
+6 ;
FTIME(Y) ; -- return formatted date/time
+1 ; input: Y := internal date/time
+2 ; output: [returned] := formatted date and time
+3 DO DD^%DT
+4 QUIT Y
+5 ;
RANGE(WHEN) ; select date range
+1 ; input: WHEN := past or future dates (optional)
+2 ; output: DGBEG := begin date
+3 ; DGEND := end date
+4 ; return: was selection made [ 1|yes 0|no]
+5 WRITE !!,$$LINE("Date Range Selection")
DATE SET DIR(0)="D^::EX"
SET DIR("A")="Enter Beginning Date"
SET DIR("?")="^D HELP^%DTC"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO RANGEQ
SET DGBEG=Y
+1 IF $GET(WHEN)="P"
IF DGBEG>(DT_.9999)
WRITE !," Future dates are not allowed.",*7
KILL DGBEG
GOTO DATE
+2 IF $GET(WHEN)="F"
IF (DGBEG_.9999)<DT
WRITE !," Past dates are not allowed.",*7
KILL DGBEG
GOTO DATE
+3 ;select ending date
+4 SET DIR(0)="D^::EX"
SET DIR("A")="Enter Ending Date"
SET DIR("?")="^D HELP^%DTC"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO RANGEQ
+5 SET DGEND=Y
+6 IF $GET(WHEN)="P"
IF DGEND>(DT_.9999)
WRITE !," Future dates are not allowed.",*7
KILL DGEND
GOTO DATE
+7 IF $GET(WHEN)="F"
IF (DGEND_.9999)<DT
WRITE !," Past dates are not allowed.",*7
KILL DGEND
GOTO DATE
+8 IF DGEND<DGBEG
WRITE !!,"Beginning Date must be prior to Ending Date"
KILL DGEND
GOTO DATE
RANGEQ QUIT $DATA(DGEND)
+1 ;
DIV() ; -- get division data
+1 ; input: none
+2 ; output: VAUTD := divs selected (VAUTD=1 for all)
+3 ; return: was selection made [ 1|yes 0|no]
+4 ;
+5 if $PIECE($GET(^DG(43,1,"GL")),U,2)
WRITE !!,$$LINE("Division Selection")
+6 DO ASK2
IF Y<0
KILL VAUTD
+7 QUIT $DATA(VAUTD)>0
+8 ;
CLINIC() ; -- get clinic data
+1 ; input: VAUTD := divisions selected
+2 ; output: VAUTC := clinic selected (VAUTC=1 for all)
+3 ; return: was selection made [ 1|yes 0|no]
+4 ;
+5 WRITE !!,$$LINE("Clinic Selection")
+6 SET DIC("S")="I $S(VAUTD:1,$D(VAUTD(+$P(^SC(Y,0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
+7 SET DIC="^SC("
SET VAUTSTR="clinic"
SET VAUTVB="VAUTC"
SET VAUTNI=2
+8 DO FIRST^VAUTOMA
+9 IF Y<0
KILL VAUTC
CLINICQ QUIT $DATA(VAUTC)>0
+1 ;
+2 ;
LINE(STR) ; -- print line
+1 ; input: STR := text to insert
+2 ; output: none
+3 ; return: text to use
+4 ;
+5 NEW X
+6 if STR]""
SET STR=" "_STR_" "
+7 SET $PIECE(X,"_",(IOM/2)-($LENGTH(STR)/2))=""
+8 QUIT X_STR_X
+9 ;
ASK2 SET (VAUTD,Y)=0
IF '$DATA(^DG(40.8,+$ORDER(^DG(40.8,0)),0))
WRITE !,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP"
GOTO ASK2Q
+1 IF '$PIECE($GET(^DG(43,1,"GL")),U,2)
SET VAUTD=1
GOTO ASK2Q
+2 IF $DATA(^DG(43,1,"GL"))
IF $PIECE(^("GL"),U,2)
GOTO DIVISION^VAUTOMA
+3 SET I=$ORDER(^DG(40.8,0))
if '$DATA(^DG(40.8,+I,0))
GOTO ASK2Q
SET VAUTD(I)=$PIECE(^(0),U)
KILL DIC
QUIT
ASK2Q ;
+1 QUIT
+2 ;
CLOSE ; Utility to clean up tasked outputs
+1 if '$DATA(ZTQUEUED)
QUIT
+2 DO KILL^%ZTLOAD
KILL ZTSK,ZTDESC,ZTRTN,ZTREQ,ZTSAVE,ZTIO,ZTDTH,ZTUCI,IO("Q"),IO("C")
+3 QUIT
+4 ;
XMY(GROUP,DGDUZ,DGPOST) ; -- set up XMY for mail group members
+1 ; input: GROUP := mail group efn [required]
+2 ; DGDUZ := send to current user [ 0|no ; 1|yes] [optional]
+3 ; DGPOST := send to postmaster if XMY is undefined
+4 ; [ 0|no ; 1|yes] [optional]
+5 ; output: XMY := array of users
+6 ; XMDUZ := message sender set postmaster
+7 ;
+8 NEW I
KILL XMY
+9 IF '$DATA(DGDUZ)
NEW DGDUZ
SET DGDUZ=1
+10 IF '$DATA(DGPOST)
NEW DGPOST
SET SDPOST=1
+11 SET XMY("G."_$PIECE($GET(^XMB(3.8,GROUP,0)),U))=""
+12 IF DGDUZ
IF DUZ
SET XMY(DUZ)=""
+13 ; makes sure it gets sent to someone
+14 IF '$DATA(XMY)
IF DGPOST
SET XMY(.5)=""
+15 ; make postmaster the sender so it will show up as new to DUZ
+16 SET XMDUZ=.5
+17 QUIT
+18 ;
+19 ;
LOCK(DFN) ;
+1 ; Description: Sets a lock used to synchronize local income test
+2 ; options with the income test upload.
+3 ;
+4 ; Input:
+5 ; DFN - ien of record in PATIENT file
+6 ;
+7 ; Output:
+8 ; Function value - returns 1 if the lock was obtained, 0 otherwise.
+9 ;
+10 if '$GET(DFN)
QUIT 1
+11 LOCK +^DGMT("LOCAL INCOME TEST",DFN):5
+12 QUIT $TEST
+13 ;
+14 ;
UNLOCK(DFN) ;
+1 ; Description: Release the lock obtained by calling $$LOCK(DFN).
+2 ;
+3 ; Input:
+4 ; DFN - ien of record in PATIENT file
+5 ;
+6 ; Output: none
+7 ;
+8 if '$GET(DFN)
QUIT
+9 LOCK -^DGMT("LOCAL INCOME TEST",DFN)
+10 QUIT
+11 ;
PA(DGMTI) ;Determine if the Pending Adjudication is for MT or GMT
+1 ; Input:
+2 ; DGMTI - IEN of Annual Means Test file #408.31
+3 ; Output:
+4 ; Returns "MT","GMT", or "" if it can't be determined
+5 ;
+6 NEW PA,DGMT0,MTTHR,GMTTHR
+7 SET PA=""
+8 IF '$GET(DGMTI)
QUIT PA
+9 SET DGMT0=$GET(^DGMT(408.31,DGMTI,0))
+10 ; If means test status is not Pending Adjudication, quit
+11 IF $PIECE(DGMT0,U,3)'=2
QUIT PA
+12 ; Get MT Threshold and GMT Threshold
+13 SET MTTHR=+$PIECE(DGMT0,U,12)
IF 'MTTHR
QUIT PA
+14 SET GMTTHR=+$PIECE(DGMT0,U,27)
+15 ; If GMT Threshold is greater than MT Threshold then return GMT,
+16 ; otherwise return MT
+17 SET PA=$SELECT(GMTTHR>MTTHR:"GMT",1:"MT")
+18 QUIT PA
+19 ;
ISCNVRT(DGINC) ;* Convert Node 0 for records in 408.21 (IAI)
+1 ; Input: DGINC - Individual Annual Income IEN Array
+2 ;
+3 NEW RESULT,IAIREC,NULLVAL,PCE,IAIIEN,TOT08,TOT201,TOT204,NWNODE
+4 SET NULLVAL=""
+5 ;
+6 ; Convert 408.21 nodes to version 1 form
+7 FOR RECTYP="V","S","D"
Begin DoDot:1
+8 IF RECTYP'="D"
Begin DoDot:2
+9 IF $DATA(DGINC(RECTYP))
Begin DoDot:3
+10 SET IAIIEN=DGINC(RECTYP)
+11 SET IAIREC=$GET(^DGMT(408.21,IAIIEN,0))
+12 SET NWNODE=$GET(^DGMT(408.21,IAIIEN,2))
+13 SET (TOT08,TOT201,TOT204)=0
+14 SET TOT201=$PIECE(NWNODE,"^",1)+$PIECE(NWNODE,"^",2)
+15 SET TOT204=$PIECE(NWNODE,"^",4)-$PIECE(NWNODE,"^",5)
+16 SET PCE=""
+17 FOR PCE=8:1:13,15,16
IF $PIECE(IAIREC,"^",PCE)'=NULLVAL
SET TOT08=TOT08+$PIECE(IAIREC,"^",PCE)
+18 NEW DGERR,DGMTRT,FLDNM
+19 SET FLDNM=""
+20 SET DGERR=""
+21 FOR FLDNM=.09:.01:.13,.15,.16,2.02,2.05
SET DGMTRT(408.21,IAIIEN_",",FLDNM)="@"
+22 SET DGMTRT(408.21,IAIIEN_",",".08")=$SELECT(TOT08>0:TOT08,1:"")
+23 SET DGMTRT(408.21,IAIIEN_",","2.01")=$SELECT(TOT201>0:TOT201,1:"")
+24 SET DGMTRT(408.21,IAIIEN_",","2.04")=$SELECT(TOT204>0:TOT204,1:"")
+25 DO FILE^DIE("E","DGMTRT",DGERR)
End DoDot:3
End DoDot:2
+26 ;
+27 IF RECTYP="D"
Begin DoDot:2
+28 NEW DEPNUM,DGMTVR
+29 SET DGMTVR=1
+30 SET DEPNUM=""
+31 FOR
SET DEPNUM=$ORDER(DGINC("D",DEPNUM))
if DEPNUM=""
QUIT
Begin DoDot:3
+32 SET IAIIEN=DGINC("D",DEPNUM)
+33 SET IAIREC=$GET(^DGMT(408.21,IAIIEN,0))
+34 SET NWNODE=$GET(^DGMT(408.21,IAIIEN,2))
+35 SET (TOT08,TOT201,TOT204)=0
+36 SET TOT201=$PIECE(NWNODE,"^",1)+$PIECE(NWNODE,"^",2)
+37 SET TOT204=$PIECE(NWNODE,"^",4)-$PIECE(NWNODE,"^",5)
+38 SET PCE=""
+39 FOR PCE=8:1:13,15,16
IF $PIECE(IAIREC,"^",PCE)'=NULLVAL
SET TOT08=TOT08+$PIECE(IAIREC,"^",PCE)
+40 NEW DGERR,DGMTRT,FLDNM
+41 SET FLDNM=""
+42 SET DGERR=""
+43 FOR FLDNM=.09:.01:.13,.15,.16,2.02,2.05
SET DGMTRT(408.21,IAIIEN_",",FLDNM)="@"
+44 SET DGMTRT(408.21,IAIIEN_",",".08")=$SELECT(TOT08>0:TOT08,1:"")
+45 SET DGMTRT(408.21,IAIIEN_",","2.01")=$SELECT(TOT201>0:TOT201,1:"")
+46 SET DGMTRT(408.21,IAIIEN_",","2.04")=$SELECT(TOT204>0:TOT204,1:"")
+47 DO FILE^DIE("E","DGMTRT",DGERR)
End DoDot:3
End DoDot:2
End DoDot:1
+48 QUIT
