DGOTHD2 ;SLC/SS,RM,RED - OTHD (OTHER THAN HONORABLE DISCHARGE) APIs ;12/27/17
;;5.3;Registration;**952**;Aug 13, 1993;Build 160
;;Per VA Directive 6402, this routine should not be modified.
; Last Edited: SHRPE/RED - May 2, 2018 15:11
;
; IA: 10103 ^XLFDT (supported) - [$$FMADD^XLFDT, $$FMTE^XLFDT , $$NOW^XLFDT]
; 10015 ^DIQ (supported) - [GETS^DIQ]
; 10026 ^DIR (supported)
; 2053 ^DIE (supported) - [FILE^DIE, UPDATE^DIE]
; 10000 ^%DTC (supported) - [NOW^%DTC]
Q
;
;create the new entry in file #33 (OTH ELIGIBILITY)
;DGDFN - patient's IEN
;returns
;IEN of the file #33
;or -1^error message
CROTHENT(DGDFN) ;
N DGVALS,DGIEN33
I $$CHCKPAT(DGDFN)'>0 Q -2 ;patient does not exist
S DGVALS(.01)=DGDFN
S DGVALS(.02)=1 ;set to ACTIVE
S DGIEN=$$INSREC(33,"",.DGVALS)
;create subfile 2 - ELIGIBILITY CHANGES (Multiple-33.02)
D CRTEELCH^DGOTHEL(DGDFN,$$HASENTRY^DGOTHD2(DGDFN),$$NOW^XLFDT())
Q DGIEN
;
;Get the user's current facility number. If not found, it will
;return the facility number of the primary facility.
GETSITE(DUZ) ;
;Input:
; DUZ array, pass by reference
;Output:
; Function Value - facility number
N FACILITY
S FACILITY=""
S:DUZ'=.5 FACILITY=DUZ(2)
I 'FACILITY S FACILITY=+$$SITE^VASITE()
Q FACILITY
;
;check if the patient has 2nd period authorization
;DGIEN33 - ien file #33
;DGI3301 - ien subfile #33.01
;CLCKNO - 90 days clock #
HAS2AUTH(DGIEN33,DGI3301,CLCKNO) ;
N DGIEN90,DGRETDAT
S DGIEN90=$$CHCK90(DGIEN33,DGI3301,CLCKNO)
I DGIEN90'>0 Q -1 ; OTH clock entry in the file #33 doesn't exist
S DGRETDAT=$G(^DGOTH(33,DGIEN33,1,DGI3301,1,DGIEN90,0))
Q $P(DGRETDAT,U,3,4)
;
;does the patient have clock?
;DGDFN - patient IEN
HASENTRY(DGDFN) ;
Q +$O(^DGOTH(33,"B",DGDFN,0))
;
;how many 365 days clock the patient has?
;DGIEN33 - ien of #33
CLCKS365(DGIEN33) ;
Q $O(^DGOTH(33,DGIEN33,1,"B",99),-1)
;
;returns
;-1 : if OTH clock entry in the file #33 doesn't exist
;0 : if 365 days clock with the number CLCKNO doesn't exist
;>0 : IEN of the 365 days clock with the number CLCKNO
CHCK365(DGIEN33,CLCKNO) ;
I +$D(^DGOTH(33,DGIEN33,0))'>0 Q -1 ;clock doesn't exist
Q +$O(^DGOTH(33,DGIEN33,1,"B",CLCKNO,0))
;
;returns
;-1 : if OTH clock entry in the file #33 doesn't exist
;0 : if 90 days clock with the number CLCKNO doesn't exist
;>0 : IEN of the 90 days clock with the number CLCKNO
CHCK90(DGIEN33,DGI3301,CLCKNO) ;
I +$D(^DGOTH(33,DGIEN33,0))'>0 Q -1 ;clock doesn't exist
I +$D(^DGOTH(33,DGIEN33,1,DGI3301,0))'>0 Q -1 ;clock doesn't exist
Q +$O(^DGOTH(33,DGIEN33,1,DGI3301,1,"B",CLCKNO,0))
;check DFN
CHCKPAT(DGDFN) ;
Q +$D(^DPT(DGDFN,0))
;
;get patient IEN by ien of the file #33
GETPAT(DGIEN33) ;
Q $P($G(^DGOTH(33,DGIEN33,0)),U)
;
;input:
;DGPROM - prompt text
;DGDFVL - default value (optional)
;returns:
; "response^"
PROMPT(DGPROM,DGDFVL) ;
N DGRET,DIR,X,Y,DIRUT,DIROUT,DTOUT,DUOUT
S DGRET="^"
S DIR(0)="F^::2",DIR("A")=DGPROM
I $L($G(DGDFVL))>0 S DIR("B")=$G(DGDFVL)
D ^DIR I $D(DIRUT) Q "^"
S $P(DGRET,U)=Y
Q DGRET
;
;This procedure is used to perform a patient lookup for an existing patient in the (#33) file.
;Parameters:
; None
;Returns:
; in DGPAT array where
; DGPAT = IEN of patient in PATIENT (#33) file on success, -1 on failure
; DGPAT(0) = zero node of entry selected
; return value IEN of patient in PATIENT (#33) file on success, -1 on failure
SELPAT(DGPAT) ;
;- int input vars for ^DIC call
N DIC,DTOUT,DUPOT,X,Y
S DIC="^DGOTH(33,",DIC(0)="AEMQZV"
;screen out all that are not ACTIVE
S DIC("S")="I $P(^(0),U,2)=1"
;- lookup patient
D ^DIC K DIC
;- result of lookup
S DGPAT=Y
;- if success, setup return array using output vars from ^DIC call
I (+DGPAT>0) D Q +Y
. S DGPAT=+Y ;patient ien
. S DGPAT(0)=$G(Y(0)) ;zero node of patient in (#33) file
Q -1
;
;/**
;Creates a new entry (or node for multiple with .01 field)
;
;DGFILE - file/subfile number
;DGIEN - ien of the parent file entry in which the new subfile entry will be inserted
;DGZFDA - array with values for the fields
; format for DGZFDA:
; DGZFDA(.01)=value for #.01 field
; DGZFDA(3)=value for #3 field
;DGRECNO -(optional) specify IEN if you want specific value
; Note: "" then the system will assign the entry number itself.
;DGFLGS - FLAGS parameter for UPDATE^DIE
;DGLCKGL - fully specified global reference to lock
;DGLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
;DGNEWRE - optional, flag = if 1 then allow to create a new top level record
;
;output :
; positive number - record # created
; <=0 - failure^error message
;
;Example:
;top level:
;S DGVALS(.01)="OTHD" W $$INSREC^DG53952(8.1,"",.DGVALS,,,,,1)
;2nd level:
;K DGVALS S DGVALS(.01)=1 W $$INSREC^DGOTHD2(33.01,"8",.DGVALS)
;3rd level:
;K DGVALS S DGVALS(.01)=1 W $$INSREC^DGOTHD2(33.11,"1,8",.DGVALS)
INSREC(DGFILE,DGIEN,DGZFDA,DGRECNO,DGFLGS,DGLCKGL,DGLCKTM,DGNEWRE) ;*/
I ('$G(DGFILE)) Q "0^Invalid parameter"
I +$G(DGNEWRE)=0 I $G(DGRECNO)>0,'$G(DGIEN) Q "0^Invalid parameter"
N DGSSI,DGIENS,DGERR,DGFDA,DIERR
N DGLOCK S DGLOCK=0
I '$G(DGRECNO) N DGRECNO S DGRECNO=$G(DGRECNO)
I DGIEN'="" S DGIENS="+1,"_DGIEN_"," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
I DGIEN="" S DGIENS="+1," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
M DGFDA(DGFILE,DGIENS)=DGZFDA
I $L($G(DGLCKGL)) L +@DGLCKGL:(+$G(DGLCKTM)) S DGLOCK=$T I 'DGLOCK Q -2 ;lock failure
D UPDATE^DIE($G(DGFLGS),"DGFDA","DGSSI","DGERR")
I DGLOCK L -@DGLCKGL
I $D(DGERR) Q "-1^"_$G(DGERR("DIERR",1,"TEXT",1),"Update Error")
Q +$G(DGSSI(1))
;
HELP3 ;display help text for 1st 90-Day period
I $G(Y)<1,X'="?",X'="??" W !," You have entered an invalid date, please enter a valid date." Q
W !," The date entered cannot be more than 90 days in the past."
W !," A future date cannot be entered."
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOTHD2 6063 printed Dec 13, 2024@02:46:47 Page 2
DGOTHD2 ;SLC/SS,RM,RED - OTHD (OTHER THAN HONORABLE DISCHARGE) APIs ;12/27/17
+1 ;;5.3;Registration;**952**;Aug 13, 1993;Build 160
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; Last Edited: SHRPE/RED - May 2, 2018 15:11
+4 ;
+5 ; IA: 10103 ^XLFDT (supported) - [$$FMADD^XLFDT, $$FMTE^XLFDT , $$NOW^XLFDT]
+6 ; 10015 ^DIQ (supported) - [GETS^DIQ]
+7 ; 10026 ^DIR (supported)
+8 ; 2053 ^DIE (supported) - [FILE^DIE, UPDATE^DIE]
+9 ; 10000 ^%DTC (supported) - [NOW^%DTC]
+10 QUIT
+11 ;
+12 ;create the new entry in file #33 (OTH ELIGIBILITY)
+13 ;DGDFN - patient's IEN
+14 ;returns
+15 ;IEN of the file #33
+16 ;or -1^error message
CROTHENT(DGDFN) ;
+1 NEW DGVALS,DGIEN33
+2 ;patient does not exist
IF $$CHCKPAT(DGDFN)'>0
QUIT -2
+3 SET DGVALS(.01)=DGDFN
+4 ;set to ACTIVE
SET DGVALS(.02)=1
+5 SET DGIEN=$$INSREC(33,"",.DGVALS)
+6 ;create subfile 2 - ELIGIBILITY CHANGES (Multiple-33.02)
+7 DO CRTEELCH^DGOTHEL(DGDFN,$$HASENTRY^DGOTHD2(DGDFN),$$NOW^XLFDT())
+8 QUIT DGIEN
+9 ;
+10 ;Get the user's current facility number. If not found, it will
+11 ;return the facility number of the primary facility.
GETSITE(DUZ) ;
+1 ;Input:
+2 ; DUZ array, pass by reference
+3 ;Output:
+4 ; Function Value - facility number
+5 NEW FACILITY
+6 SET FACILITY=""
+7 if DUZ'=.5
SET FACILITY=DUZ(2)
+8 IF 'FACILITY
SET FACILITY=+$$SITE^VASITE()
+9 QUIT FACILITY
+10 ;
+11 ;check if the patient has 2nd period authorization
+12 ;DGIEN33 - ien file #33
+13 ;DGI3301 - ien subfile #33.01
+14 ;CLCKNO - 90 days clock #
HAS2AUTH(DGIEN33,DGI3301,CLCKNO) ;
+1 NEW DGIEN90,DGRETDAT
+2 SET DGIEN90=$$CHCK90(DGIEN33,DGI3301,CLCKNO)
+3 ; OTH clock entry in the file #33 doesn't exist
IF DGIEN90'>0
QUIT -1
+4 SET DGRETDAT=$GET(^DGOTH(33,DGIEN33,1,DGI3301,1,DGIEN90,0))
+5 QUIT $PIECE(DGRETDAT,U,3,4)
+6 ;
+7 ;does the patient have clock?
+8 ;DGDFN - patient IEN
HASENTRY(DGDFN) ;
+1 QUIT +$ORDER(^DGOTH(33,"B",DGDFN,0))
+2 ;
+3 ;how many 365 days clock the patient has?
+4 ;DGIEN33 - ien of #33
CLCKS365(DGIEN33) ;
+1 QUIT $ORDER(^DGOTH(33,DGIEN33,1,"B",99),-1)
+2 ;
+3 ;returns
+4 ;-1 : if OTH clock entry in the file #33 doesn't exist
+5 ;0 : if 365 days clock with the number CLCKNO doesn't exist
+6 ;>0 : IEN of the 365 days clock with the number CLCKNO
CHCK365(DGIEN33,CLCKNO) ;
+1 ;clock doesn't exist
IF +$DATA(^DGOTH(33,DGIEN33,0))'>0
QUIT -1
+2 QUIT +$ORDER(^DGOTH(33,DGIEN33,1,"B",CLCKNO,0))
+3 ;
+4 ;returns
+5 ;-1 : if OTH clock entry in the file #33 doesn't exist
+6 ;0 : if 90 days clock with the number CLCKNO doesn't exist
+7 ;>0 : IEN of the 90 days clock with the number CLCKNO
CHCK90(DGIEN33,DGI3301,CLCKNO) ;
+1 ;clock doesn't exist
IF +$DATA(^DGOTH(33,DGIEN33,0))'>0
QUIT -1
+2 ;clock doesn't exist
IF +$DATA(^DGOTH(33,DGIEN33,1,DGI3301,0))'>0
QUIT -1
+3 QUIT +$ORDER(^DGOTH(33,DGIEN33,1,DGI3301,1,"B",CLCKNO,0))
+4 ;check DFN
CHCKPAT(DGDFN) ;
+1 QUIT +$DATA(^DPT(DGDFN,0))
+2 ;
+3 ;get patient IEN by ien of the file #33
GETPAT(DGIEN33) ;
+1 QUIT $PIECE($GET(^DGOTH(33,DGIEN33,0)),U)
+2 ;
+3 ;input:
+4 ;DGPROM - prompt text
+5 ;DGDFVL - default value (optional)
+6 ;returns:
+7 ; "response^"
PROMPT(DGPROM,DGDFVL) ;
+1 NEW DGRET,DIR,X,Y,DIRUT,DIROUT,DTOUT,DUOUT
+2 SET DGRET="^"
+3 SET DIR(0)="F^::2"
SET DIR("A")=DGPROM
+4 IF $LENGTH($GET(DGDFVL))>0
SET DIR("B")=$GET(DGDFVL)
+5 DO ^DIR
IF $DATA(DIRUT)
QUIT "^"
+6 SET $PIECE(DGRET,U)=Y
+7 QUIT DGRET
+8 ;
+9 ;This procedure is used to perform a patient lookup for an existing patient in the (#33) file.
+10 ;Parameters:
+11 ; None
+12 ;Returns:
+13 ; in DGPAT array where
+14 ; DGPAT = IEN of patient in PATIENT (#33) file on success, -1 on failure
+15 ; DGPAT(0) = zero node of entry selected
+16 ; return value IEN of patient in PATIENT (#33) file on success, -1 on failure
SELPAT(DGPAT) ;
+1 ;- int input vars for ^DIC call
+2 NEW DIC,DTOUT,DUPOT,X,Y
+3 SET DIC="^DGOTH(33,"
SET DIC(0)="AEMQZV"
+4 ;screen out all that are not ACTIVE
+5 SET DIC("S")="I $P(^(0),U,2)=1"
+6 ;- lookup patient
+7 DO ^DIC
KILL DIC
+8 ;- result of lookup
+9 SET DGPAT=Y
+10 ;- if success, setup return array using output vars from ^DIC call
+11 IF (+DGPAT>0)
Begin DoDot:1
+12 ;patient ien
SET DGPAT=+Y
+13 ;zero node of patient in (#33) file
SET DGPAT(0)=$GET(Y(0))
End DoDot:1
QUIT +Y
+14 QUIT -1
+15 ;
+16 ;/**
+17 ;Creates a new entry (or node for multiple with .01 field)
+18 ;
+19 ;DGFILE - file/subfile number
+20 ;DGIEN - ien of the parent file entry in which the new subfile entry will be inserted
+21 ;DGZFDA - array with values for the fields
+22 ; format for DGZFDA:
+23 ; DGZFDA(.01)=value for #.01 field
+24 ; DGZFDA(3)=value for #3 field
+25 ;DGRECNO -(optional) specify IEN if you want specific value
+26 ; Note: "" then the system will assign the entry number itself.
+27 ;DGFLGS - FLAGS parameter for UPDATE^DIE
+28 ;DGLCKGL - fully specified global reference to lock
+29 ;DGLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
+30 ;DGNEWRE - optional, flag = if 1 then allow to create a new top level record
+31 ;
+32 ;output :
+33 ; positive number - record # created
+34 ; <=0 - failure^error message
+35 ;
+36 ;Example:
+37 ;top level:
+38 ;S DGVALS(.01)="OTHD" W $$INSREC^DG53952(8.1,"",.DGVALS,,,,,1)
+39 ;2nd level:
+40 ;K DGVALS S DGVALS(.01)=1 W $$INSREC^DGOTHD2(33.01,"8",.DGVALS)
+41 ;3rd level:
+42 ;K DGVALS S DGVALS(.01)=1 W $$INSREC^DGOTHD2(33.11,"1,8",.DGVALS)
INSREC(DGFILE,DGIEN,DGZFDA,DGRECNO,DGFLGS,DGLCKGL,DGLCKTM,DGNEWRE) ;*/
+1 IF ('$GET(DGFILE))
QUIT "0^Invalid parameter"
+2 IF +$GET(DGNEWRE)=0
IF $GET(DGRECNO)>0
IF '$GET(DGIEN)
QUIT "0^Invalid parameter"
+3 NEW DGSSI,DGIENS,DGERR,DGFDA,DIERR
+4 NEW DGLOCK
SET DGLOCK=0
+5 IF '$GET(DGRECNO)
NEW DGRECNO
SET DGRECNO=$GET(DGRECNO)
+6 IF DGIEN'=""
SET DGIENS="+1,"_DGIEN_","
IF $LENGTH(DGRECNO)>0
SET DGSSI(1)=+DGRECNO
+7 IF DGIEN=""
SET DGIENS="+1,"
IF $LENGTH(DGRECNO)>0
SET DGSSI(1)=+DGRECNO
+8 MERGE DGFDA(DGFILE,DGIENS)=DGZFDA
+9 ;lock failure
IF $LENGTH($GET(DGLCKGL))
LOCK +@DGLCKGL:(+$GET(DGLCKTM))
SET DGLOCK=$TEST
IF 'DGLOCK
QUIT -2
+10 DO UPDATE^DIE($GET(DGFLGS),"DGFDA","DGSSI","DGERR")
+11 IF DGLOCK
LOCK -@DGLCKGL
+12 IF $DATA(DGERR)
QUIT "-1^"_$GET(DGERR("DIERR",1,"TEXT",1),"Update Error")
+13 QUIT +$GET(DGSSI(1))
+14 ;
HELP3 ;display help text for 1st 90-Day period
+1 IF $GET(Y)<1
IF X'="?"
IF X'="??"
WRITE !," You have entered an invalid date, please enter a valid date."
QUIT
+2 WRITE !," The date entered cannot be more than 90 days in the past."
+3 WRITE !," A future date cannot be entered."
+4 QUIT
+5 ;
