Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENU

DGENU.m

Go to the documentation of this file.
  1. DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TMK,PWC,TDM,JLS,HM - Enrollment Utilities ;04/24/2006 9:20 AM
  1. ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653,688,536,838,841,909,940,972,952,993**;Aug 13,1993;Build 92
  1. ;
  1. DISPLAY(DFN) ;
  1. ;Description: Display status message, current enrollment and
  1. ; preferred facility information
  1. ;Input:
  1. ; DFN - Patient IEN
  1. ; Output: none
  1. ;
  1. N STATUS
  1. S STATUS=$$STATUS^DGENA(DFN)
  1. I 'STATUS W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
  1. E I STATUS=2 D
  1. .W !!,"Patient is enrolled in the VA Patient Enrollment System..."
  1. ; Purple Heart added status 21
  1. E I (STATUS=9)!(STATUS=1)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) D
  1. .W !!,"Application is pending for enrollment in the VA Patient Enrollment System..."
  1. E D
  1. .W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
  1. D CUR(DFN)
  1. Q
  1. ;
  1. CUR(DFN) ;
  1. ;Description - displays current enrollment, category, enrollment
  1. ; group threshold, preferred facility and source designation
  1. ;
  1. N FACNAME,PREFAC,PFSRC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF
  1. I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
  1. ;Get enrollment category
  1. S DGENCAT=$$CATEGORY^DGENA4(DFN)
  1. ;Display Category in reverse video
  1. D REV
  1. ;Get enrollment group threshold
  1. S DGEGTIEN=$$FINDCUR^DGENEGT
  1. S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
  1. ;Preferred facility
  1. S PREFAC=$$PREF^DGENPTA(DFN,.FACNAME)
  1. ;Source Designation
  1. S PFSRC=$$GET1^DIQ(2,DFN_",",27.03)
  1. W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
  1. W !?3,"Application Date",?35,": ",$S('$G(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP")))
  1. W !?3,IORVON,"Enrollment Category : ",$S($G(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF
  1. W !?3,"Enrollment Status",?35,": ",$S($G(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS")))
  1. W !?3,"Enrollment Priority",?35,": ",$S($G(DGENR("PRIORITY"))="":"-none-",1:DGENR("PRIORITY")),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT("SUBGRP",DGENR("SUBGRP")))
  1. W !?3,"Preferred Facility",?35,": ",$S($G(FACNAME)'="":FACNAME,1:"-none-")
  1. W !?3,"Preferred Facility Source",?35,": ",$S($G(PFSRC)'="":PFSRC,1:"-none-")
  1. W !?3,"Enrollment Group Threshold",?35,": ",$S($G(DGEGT("PRIORITY"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"",$G(DGEGT("PRIORITY")))),$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"",$G(DGEGT("SUBGRP"))))
  1. W !
  1. Q
  1. REV ;Get variables to display text in reverse video
  1. N X
  1. S X="IORVON;IORVOFF"
  1. D ENDR^%ZISS
  1. Q
  1. PATID(DFN) ;
  1. ;Description - Called by FileMan as an identifier for the Patient file.
  1. ;Displays current enrollment status, priority, and preferred facility.
  1. ;
  1. ;Input:
  1. ; DFN - ien to Patient file
  1. ;
  1. N PREFAC,DGENR,OUTPUT
  1. I '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) D
  1. .S OUTPUT="NO ENROLLMENT APPLICATION ON FILE "
  1. E D
  1. .S OUTPUT=$E("PRIORITY:"_DGENR("PRIORITY")_" ",1,12)_$E("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_" ",1,26)
  1. S PREFAC=$$PREF^DGENPTA(DFN)
  1. S:PREFAC OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$P($G(^DIC(4,PREFAC,99)),"^")
  1. I $G(IOM) I ($X#$G(IOM))<6 D
  1. .D EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))")
  1. E D
  1. .D EN^DDIOL(OUTPUT,,"!?10")
  1. Q
  1. ;
  1. EXT(SUB,VAL) ;
  1. ;Description: Given the subscript used in the PATIENT ENROLLMENT array,
  1. ; and a field value, returns the external representation of the
  1. ; value, as defined in the fields output transform of the PATIENT
  1. ; ENROLLMENT file.
  1. ;Input:
  1. ; SUB - subscript in the array defined by the PATIENT ENROLLMENT object
  1. ; VAL - value of the PATIENT ENROLLMENT object attribute named by SUB
  1. ;Output:
  1. ; Function Value - returns the external value of the attribute as
  1. ; defined by the PATIENT ENROLLMENT file
  1. ;
  1. Q:(($G(SUB)="")!($G(VAL)="")) ""
  1. ;
  1. N FLD
  1. S FLD=$$FIELD(SUB)
  1. ;
  1. Q:(FLD="") ""
  1. Q $$EXTERNAL^DILFD(27.11,FLD,"F",VAL)
  1. ;
  1. FIELD(SUB) ;
  1. ;Description: given a subscript in the enrollment array, returns the
  1. ; corresponding field number
  1. N FLD S FLD=""
  1. D ;drops out of block once SUB is determined
  1. .I SUB="APP" S FLD=.01 Q
  1. .I SUB="DATE" S FLD=.1 Q
  1. .I SUB="END" S FLD=.11 Q
  1. .I SUB="DFN" S FLD=.02 Q
  1. .I SUB="SOURCE" S FLD=.03 Q
  1. .I SUB="STATUS" S FLD=.04 Q
  1. .I SUB="REASON" S FLD=.05 Q
  1. .I SUB="REMARKS" S FLD=25 Q
  1. .I SUB="FACREC" S FLD=.06 Q
  1. .I SUB="PRIORITY" S FLD=.07 Q
  1. .I SUB="EFFDATE" S FLD=.08 Q
  1. .I SUB="PRIORREC" S FLD=.09 Q
  1. .I SUB="SUBGRP" S FLD=.12 Q
  1. .I SUB="RCODE" S FLD=.13 Q ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
  1. .;DG*5.3*993 Four new fields for decoupling
  1. .I SUB="PTAPPLIED" S FLD=.14 Q
  1. .I SUB="REGREA" S FLD=.15 Q
  1. .I SUB="REGDATE" S FLD=.16 Q
  1. .I SUB="REGSRC" S FLD=.17 Q
  1. .;End of DG*5.3*993 mods
  1. .I SUB="CODE" S FLD=50.01 Q
  1. .I SUB="SC" S FLD=50.02 Q
  1. .I SUB="SCPER" S FLD=50.03 Q
  1. .I SUB="POW" S FLD=50.04 Q
  1. .I SUB="A&A" S FLD=50.05 Q
  1. .I SUB="HB" S FLD=50.06 Q
  1. .I SUB="VAPEN" S FLD=50.07 Q
  1. .I SUB="VACKAMT" S FLD=50.08 Q
  1. .I SUB="DISRET" S FLD=50.09 Q
  1. .I SUB="DISLOD" S FLD=50.2 Q ;field added with DG*5.3*672
  1. .I SUB="MEDICAID" S FLD=50.1 Q
  1. .I SUB="AO" S FLD=50.11 Q
  1. .I SUB="AOEXPLOC" S FLD=50.22 Q ;field added with DG*5.3*688
  1. .I SUB="IR" S FLD=50.12 Q
  1. .I SUB="EC" S FLD=50.13 Q ;name now SW Asia Con, was Env Con DG*5.3*688
  1. .I SUB="MTSTA" S FLD=50.14 Q
  1. .I SUB="VCD" S FLD=50.15 Q
  1. .I SUB="PH" S FLD=50.16 Q
  1. .I SUB="UNEMPLOY" S FLD=50.17 Q
  1. .I SUB="CVELEDT" S FLD=50.18 Q
  1. .I SUB="SHAD" S FLD=50.19 Q ;field added with DG*5.3*653
  1. .I SUB="MOH" S FLD=50.23 Q
  1. .I SUB="CLE" S FLD=50.24 Q ;field added with DG*5.3*909
  1. .I SUB="CLEDT" S FLD=50.25 Q ;field added with DG*5.3*909
  1. .I SUB="CLEST" S FLD=50.26 Q ;field added with DG*5.3*909
  1. .I SUB="CLESOR" S FLD=50.27 Q ;field added with DG*5.3*909
  1. .I SUB="MOHAWRDDATE" S FLD=50.28 Q ;field added with DG*5.3*972 HM
  1. .I SUB="MOHSTATDATE" S FLD=50.29 Q ;field added with DG*5.3*972 HM
  1. .I SUB="MOHEXEMPDATE" S FLD=50.3 Q ;field added with DG*5.3*972 HM
  1. .I SUB="OTHTYPE" S FLD=50.31 Q ; DG*5.3*952
  1. .I SUB="DATETIME" S FLD=75.01 Q
  1. .I SUB="USER" S FLD=75.02 Q
  1. .I SUB="RADEXPM" S FLD=76 Q
  1. Q FLD
  1. ;
  1. PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ;
  1. ;Description: requests user to enter a single field value.
  1. ;Input:
  1. ; FILE - the file #
  1. ; FIELD - the field #
  1. ; DEFAULT - default value, internal form
  1. ; REQUIRE - a flag, (+value)'=0 means to require a value to be
  1. ; entered and to return failure otherwise (optional)
  1. ; PRMPTNM - Optional
  1. ; 0 - display field LABEL
  1. ; 1 - Prompt field TITLE
  1. ;Output:
  1. ; Function Value - 0 on failure, 1 on success
  1. ; RESPONSE - value entered by user, pass by reference
  1. ;
  1. Q:(('$G(FILE))!('$G(FIELD))) 0
  1. S REQUIRE=$G(REQUIRE)
  1. S PRMPTNM=$G(PRMPTNM)
  1. N DIR,DA,QUIT,AGAIN
  1. ;
  1. S DIR(0)=FILE_","_FIELD_$S($G(REQUIRE):"",1:"O")_"AO"
  1. I $G(DEFAULT)'="" DO
  1. . S:+$G(PRMPTNM)=0 DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
  1. . S:+$G(PRMPTNM)>0 DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
  1. S QUIT=0
  1. F D Q:QUIT
  1. . D ^DIR
  1. . I $D(DTOUT)!$D(DUOUT) S QUIT=1 Q
  1. . I X="@" D Q:AGAIN
  1. . . S AGAIN=0
  1. . . I 'REQUIRE,"Yy"'[$E($$YN^DGENCD1(" Are you sure")_"X") S AGAIN=1 Q
  1. . . S RESPONSE="" ; This might trigger the "required" message below.
  1. . E I X="" S RESPONSE=$G(DEFAULT)
  1. . E S RESPONSE=$P(Y,"^")
  1. . ;
  1. . ; quit this loop if the user entered value OR value not required
  1. . I RESPONSE'="" S QUIT=1 Q
  1. . I 'REQUIRE S QUIT=1 Q
  1. . W !,"This is a required response. Enter '^' to exit"
  1. I $D(DTOUT)!$D(DUOUT) Q 0
  1. Q 1
  1. ;
  1. INST(VADUZ,VACHK) ;
  1. ; Description: Determine the institution affiliation associated with a
  1. ; user.
  1. ;
  1. ; Input:
  1. ; VADUZ = array if passed by reference:
  1. ; VADUZ = DUZ
  1. ; VADUZ(2) =
  1. ; o if this value is null: DUZ(2) (institution affiliated
  1. ; with user, prompted at Kernel sign-on)
  1. ; o if value is not null: site to check as valid for the
  1. ; user (Pointer to INSTITUTION (#4) file)
  1. ; Output:
  1. ; Function Value - Returns pointer to the INSTITUTION (#4) file
  1. ; entry that is associated with the user, otherwise the pointer
  1. ; to the INSTITUTION (#4) file entry of the primary VA Medical
  1. ; Center division is returned.
  1. ;
  1. ; VACHK = passed by reference, returned as:
  1. ; null if the value in VADUZ(2) is null
  1. ; 0 if the value in VADUZ(2) is not null and is not a valid
  1. ; site for the user
  1. ; 1 if the value in VADUZ(2) is not null and is a valid site
  1. ; for the user
  1. ;
  1. S VACHK=$S($G(VADUZ(2))="":"",1:0)
  1. I $G(VADUZ(2)) D
  1. . N X,ZZ
  1. . Q:'$G(VADUZ)
  1. . S X=$$DIV4^XUSER(.ZZ,VADUZ)
  1. . I X,$D(ZZ(VADUZ(2))) S VACHK=1
  1. I '$G(VADUZ(2)) S VADUZ(2)=$G(DUZ(2))
  1. Q $S($G(VADUZ(2)):VADUZ(2),1:$P($$SITE^VASITE(),"^"))
  1. ;
  1. GETINST(DGPREFAC,DGINST) ;Get Institution file data
  1. ; Input -- DGPREFAC Institution file IEN
  1. ; Output -- 1=Successful and 0=Failure
  1. ; DGINST - Institution file Array
  1. N DGINST0,DGINST99,DGOKF
  1. S DGINST0=$G(^DIC(4,DGPREFAC,0)) G GETQ:DGINST0=""
  1. S DGINST("NAME")=$P(DGINST0,U)
  1. S DGINST99=$G(^DIC(4,DGPREFAC,99))
  1. S DGINST("STANUM")=$P(DGINST99,U)
  1. S DGOKF=1
  1. GETQ Q +$G(DGOKF)