- 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 Jan 18, 2025@03:47:28 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 ;