Released DG*5.3*1069 SEQ #938 Extracted from mail message **KIDS**:DG*5.3*1069^ **INSTALL NAME** DG*5.3*1069 "BLD",12494,0) DG*5.3*1069^REGISTRATION^0^3220209^y "BLD",12494,1,0) ^^3^3^3211216^ "BLD",12494,1,1,0) Patch DG*5.3*1069 addresses an issue introduced by patch DG*5.3*1054 that "BLD",12494,1,2,0) eliminated PRF Queries to be sent to non-medical treating facilities. "BLD",12494,1,3,0) 200CRNR is considered a VAMC and should therefor receive the PRF Query. "BLD",12494,4,0) ^9.64PA^^ "BLD",12494,6) 3 "BLD",12494,6.3) 3 "BLD",12494,"KRN",0) ^9.67PA^1.5^25 "BLD",12494,"KRN",.4,0) .4 "BLD",12494,"KRN",.401,0) .401 "BLD",12494,"KRN",.402,0) .402 "BLD",12494,"KRN",.403,0) .403 "BLD",12494,"KRN",.5,0) .5 "BLD",12494,"KRN",.84,0) .84 "BLD",12494,"KRN",1.5,0) 1.5 "BLD",12494,"KRN",1.6,0) 1.6 "BLD",12494,"KRN",1.61,0) 1.61 "BLD",12494,"KRN",1.62,0) 1.62 "BLD",12494,"KRN",3.6,0) 3.6 "BLD",12494,"KRN",3.8,0) 3.8 "BLD",12494,"KRN",9.2,0) 9.2 "BLD",12494,"KRN",9.8,0) 9.8 "BLD",12494,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",12494,"KRN",9.8,"NM",1,0) DGPFUT2^^0^B51900762 "BLD",12494,"KRN",9.8,"NM","B","DGPFUT2",1) "BLD",12494,"KRN",19,0) 19 "BLD",12494,"KRN",19.1,0) 19.1 "BLD",12494,"KRN",101,0) 101 "BLD",12494,"KRN",409.61,0) 409.61 "BLD",12494,"KRN",771,0) 771 "BLD",12494,"KRN",779.2,0) 779.2 "BLD",12494,"KRN",870,0) 870 "BLD",12494,"KRN",8989.51,0) 8989.51 "BLD",12494,"KRN",8989.52,0) 8989.52 "BLD",12494,"KRN",8993,0) 8993 "BLD",12494,"KRN",8994,0) 8994 "BLD",12494,"KRN","B",.4,.4) "BLD",12494,"KRN","B",.401,.401) "BLD",12494,"KRN","B",.402,.402) "BLD",12494,"KRN","B",.403,.403) "BLD",12494,"KRN","B",.5,.5) "BLD",12494,"KRN","B",.84,.84) "BLD",12494,"KRN","B",1.5,1.5) "BLD",12494,"KRN","B",1.6,1.6) "BLD",12494,"KRN","B",1.61,1.61) "BLD",12494,"KRN","B",1.62,1.62) "BLD",12494,"KRN","B",3.6,3.6) "BLD",12494,"KRN","B",3.8,3.8) "BLD",12494,"KRN","B",9.2,9.2) "BLD",12494,"KRN","B",9.8,9.8) "BLD",12494,"KRN","B",19,19) "BLD",12494,"KRN","B",19.1,19.1) "BLD",12494,"KRN","B",101,101) "BLD",12494,"KRN","B",409.61,409.61) "BLD",12494,"KRN","B",771,771) "BLD",12494,"KRN","B",779.2,779.2) "BLD",12494,"KRN","B",870,870) "BLD",12494,"KRN","B",8989.51,8989.51) "BLD",12494,"KRN","B",8989.52,8989.52) "BLD",12494,"KRN","B",8993,8993) "BLD",12494,"KRN","B",8994,8994) "BLD",12494,"QDEF") ^^^^^^^^^^YES "BLD",12494,"QUES",0) ^9.62^^ "BLD",12494,"REQB",0) ^9.611^1^1 "BLD",12494,"REQB",1,0) DG*5.3*1054^1 "BLD",12494,"REQB","B","DG*5.3*1054",1) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 1069^3220209 "PKG",5,22,1,"PAH",1,1,0) ^^3^3^3220209 "PKG",5,22,1,"PAH",1,1,1,0) Patch DG*5.3*1069 addresses an issue introduced by patch DG*5.3*1054 that "PKG",5,22,1,"PAH",1,1,2,0) eliminated PRF Queries to be sent to non-medical treating facilities. "PKG",5,22,1,"PAH",1,1,3,0) 200CRNR is considered a VAMC and should therefor receive the PRF Query. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 1 "RTN","DGPFUT2") 0^1^B51900762^B48290347 "RTN","DGPFUT2",1,0) DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 2/12/2020 "RTN","DGPFUT2",2,0) ;;5.3;Registration;**425,554,650,1005,1028,1054,1069**;Aug 13, 1993;Build 3 "RTN","DGPFUT2",3,0) ; "RTN","DGPFUT2",4,0) ; This routine contains generic calls for use throughout DGPF*. "RTN","DGPFUT2",5,0) ; "RTN","DGPFUT2",6,0) ;- no direct entry "RTN","DGPFUT2",7,0) QUIT "RTN","DGPFUT2",8,0) ; "RTN","DGPFUT2",9,0) ; "RTN","DGPFUT2",10,0) GETPAT(DGDFN,DGPAT) ;retrieve patient identifying information "RTN","DGPFUT2",11,0) ; Used to obtain identifying information for a patient "RTN","DGPFUT2",12,0) ; in the PATIENT (#2) file and place it in an array format. "RTN","DGPFUT2",13,0) ; "RTN","DGPFUT2",14,0) ; NOTE: Direct global reference of patient's zero node in the "RTN","DGPFUT2",15,0) ; PATIENT (#2) file is supported by DBIA #10035 "RTN","DGPFUT2",16,0) ; "RTN","DGPFUT2",17,0) ; Input: "RTN","DGPFUT2",18,0) ; DGDFN - (required) ien of patient in PATIENT (#2) file "RTN","DGPFUT2",19,0) ; "RTN","DGPFUT2",20,0) ; Output: "RTN","DGPFUT2",21,0) ; Function Value - returns 1 on success, 0 on failure "RTN","DGPFUT2",22,0) ; DGPAT - output array containing the patient identifying information, "RTN","DGPFUT2",23,0) ; on success, pass by reference. "RTN","DGPFUT2",24,0) ; Array subscripts are: "RTN","DGPFUT2",25,0) ; "DFN" - ien PATIENT (#2) file "RTN","DGPFUT2",26,0) ; "NAME" - patient name "RTN","DGPFUT2",27,0) ; "SSN" - patient Social Security Number "RTN","DGPFUT2",28,0) ; "DOB" - patient date of birth (FM format) "RTN","DGPFUT2",29,0) ; "SEX" - patient sex "RTN","DGPFUT2",30,0) ; "RTN","DGPFUT2",31,0) N DGNODE "RTN","DGPFUT2",32,0) N RESULT "RTN","DGPFUT2",33,0) ; "RTN","DGPFUT2",34,0) S RESULT=0 "RTN","DGPFUT2",35,0) ; "RTN","DGPFUT2",36,0) I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D "RTN","DGPFUT2",37,0) . "RTN","DGPFUT2",38,0) . ;-- obtain zero node of patient record (supported by DBIA #10035) "RTN","DGPFUT2",39,0) . S DGNODE=$G(^DPT(DGDFN,0)) "RTN","DGPFUT2",40,0) . ; "RTN","DGPFUT2",41,0) . S DGPAT("DFN")=DGDFN "RTN","DGPFUT2",42,0) . S DGPAT("NAME")=$P(DGNODE,"^") "RTN","DGPFUT2",43,0) . S DGPAT("SEX")=$P(DGNODE,"^",2) "RTN","DGPFUT2",44,0) . S DGPAT("DOB")=$P(DGNODE,"^",3) "RTN","DGPFUT2",45,0) . S DGPAT("SSN")=$P(DGNODE,"^",9) "RTN","DGPFUT2",46,0) . S RESULT=1 ;success "RTN","DGPFUT2",47,0) ; "RTN","DGPFUT2",48,0) Q RESULT "RTN","DGPFUT2",49,0) ; "RTN","DGPFUT2",50,0) GETDFN(DGICN,DGEROOT) ;Used to convert an ICN to a DFN. "RTN","DGPFUT2",51,0) ; "RTN","DGPFUT2",52,0) ; Supported DBIA #2701: The supported DBIA is used to retrieve the "RTN","DGPFUT2",53,0) ; pointer (DFN) to the PATIENT (#2) file for a "RTN","DGPFUT2",54,0) ; given ICN. "RTN","DGPFUT2",55,0) ; "RTN","DGPFUT2",56,0) ; Input: "RTN","DGPFUT2",57,0) ; DGICN - Integrated Control Number with or without checksum "RTN","DGPFUT2",58,0) ; DGEROOT - (optional) closed root array name (i.e. "DGERROR") for "RTN","DGPFUT2",59,0) ; error dialog returned from BLD^DIALOG. If not passed, "RTN","DGPFUT2",60,0) ; error dialog is returned in ^TMP("DIERR",$J) global. "RTN","DGPFUT2",61,0) ; "RTN","DGPFUT2",62,0) ; Output: "RTN","DGPFUT2",63,0) ; Function Value - DFN on success, 0 on failure "RTN","DGPFUT2",64,0) ; DGEROOT() - error output array from BLD^DIALOG "RTN","DGPFUT2",65,0) ; "RTN","DGPFUT2",66,0) N DGDFN ;ptr to patient "RTN","DGPFUT2",67,0) N DIERR ;var returned from BLD^DIALOG "RTN","DGPFUT2",68,0) ; "RTN","DGPFUT2",69,0) ;init error output array if passed "RTN","DGPFUT2",70,0) S DGEROOT=$G(DGEROOT) "RTN","DGPFUT2",71,0) I DGEROOT]"" K @DGEROOT "RTN","DGPFUT2",72,0) ; "RTN","DGPFUT2",73,0) S DGDFN=+$$GETDFN^MPIF001(+$G(DGICN)) "RTN","DGPFUT2",74,0) I DGDFN'>0 D BLD^DIALOG(261127,,,DGEROOT,"F") "RTN","DGPFUT2",75,0) ; "RTN","DGPFUT2",76,0) Q $S(DGDFN'>0:0,1:DGDFN) "RTN","DGPFUT2",77,0) ; "RTN","DGPFUT2",78,0) SORT(DGPFARR) ;Re-sort of active record assignments by category then flag name "RTN","DGPFUT2",79,0) ; This function re-sorts the active record flag assignment list for a "RTN","DGPFUT2",80,0) ; patient by category (Cat I or Cat II) and then by flag name. "RTN","DGPFUT2",81,0) ; "RTN","DGPFUT2",82,0) ; Input: [Required] "RTN","DGPFUT2",83,0) ; DGPFARR - Closed root reference array name of active assignments "RTN","DGPFUT2",84,0) ; to be sorted "RTN","DGPFUT2",85,0) ; "RTN","DGPFUT2",86,0) ; Output: "RTN","DGPFUT2",87,0) ; Function Value - returns 1 on success, 0 on failure "RTN","DGPFUT2",88,0) ; "RTN","DGPFUT2",89,0) ; DGPFARR() - Closed Root reference name of re-sorted assignments "RTN","DGPFUT2",90,0) ; - Category I's will sort first in the returned array. "RTN","DGPFUT2",91,0) ; - Category II's will sort second. "RTN","DGPFUT2",92,0) ; "RTN","DGPFUT2",93,0) N DGCAT ;category "RTN","DGPFUT2",94,0) N DGINDX ;index array "RTN","DGPFUT2",95,0) N DGNAME ;flag name "RTN","DGPFUT2",96,0) N DGSORT ;re-sorted data array "RTN","DGPFUT2",97,0) N DGX ;generic counter "RTN","DGPFUT2",98,0) ; "RTN","DGPFUT2",99,0) ; check for input value - Quit if none found "RTN","DGPFUT2",100,0) Q:DGPFARR']"" 0 "RTN","DGPFUT2",101,0) Q:'$O(@DGPFARR@("")) 0 "RTN","DGPFUT2",102,0) ; "RTN","DGPFUT2",103,0) S DGSORT=$NA(^TMP("DGPFUT2",$J)) "RTN","DGPFUT2",104,0) K @DGSORT "RTN","DGPFUT2",105,0) ; "RTN","DGPFUT2",106,0) ;build index - ARRAY(Category (I or II),Flag Name)=sort number "RTN","DGPFUT2",107,0) S DGX=0 "RTN","DGPFUT2",108,0) F S DGX=$O(@DGPFARR@(DGX)) Q:'DGX D "RTN","DGPFUT2",109,0) . S DGCAT=$S($P(@DGPFARR@(DGX,"FLAG"),U)[26.11:2,1:1) "RTN","DGPFUT2",110,0) . S DGINDX(DGCAT,$P(@DGPFARR@(DGX,"FLAG"),U,2))=DGX "RTN","DGPFUT2",111,0) ; "RTN","DGPFUT2",112,0) ;build sorted data array - "RTN","DGPFUT2",113,0) S (DGCAT,DGX)=0 "RTN","DGPFUT2",114,0) F S DGCAT=$O(DGINDX(DGCAT)) Q:'DGCAT D "RTN","DGPFUT2",115,0) . S DGNAME="" "RTN","DGPFUT2",116,0) . F S DGNAME=$O(DGINDX(DGCAT,DGNAME)) Q:DGNAME="" D "RTN","DGPFUT2",117,0) . . S DGX=DGX+1 "RTN","DGPFUT2",118,0) . . M @DGSORT@(DGX)=@DGPFARR@(DGINDX(DGCAT,DGNAME)) "RTN","DGPFUT2",119,0) ; "RTN","DGPFUT2",120,0) ;remove input array and replace with sorted array, kill sort array "RTN","DGPFUT2",121,0) K @DGPFARR "RTN","DGPFUT2",122,0) M @DGPFARR=@DGSORT "RTN","DGPFUT2",123,0) K @DGSORT "RTN","DGPFUT2",124,0) ; "RTN","DGPFUT2",125,0) Q 1 "RTN","DGPFUT2",126,0) ; "RTN","DGPFUT2",127,0) ACTDT ; update PRF Software Activation Date field in (#26.18) "RTN","DGPFUT2",128,0) ; This utility should only be run at the Alpha and Beta test sites "RTN","DGPFUT2",129,0) ; of the Patient Record Flags Project, Patch DG*5.3*425. "RTN","DGPFUT2",130,0) ; If necessary, this entry point will change the date that the "RTN","DGPFUT2",131,0) ; Patient Record Flags (PRF) System became active. "RTN","DGPFUT2",132,0) ; The (#1) PRF SOFTWARE ACTIVATION DATE field of the (#26.18) PRF "RTN","DGPFUT2",133,0) ; PARAMETERS file, will be changed to: SEP 25, 2003 "RTN","DGPFUT2",134,0) ; "RTN","DGPFUT2",135,0) ; Input: none "RTN","DGPFUT2",136,0) ; "RTN","DGPFUT2",137,0) ; Output: User message on successful or failure of file update "RTN","DGPFUT2",138,0) ; "RTN","DGPFUT2",139,0) N DGACTDT ; Nationally Released Software Activation Date value "RTN","DGPFUT2",140,0) N DGIENS ; IEN - internal entry # OF (#26.18) FILE "RTN","DGPFUT2",141,0) N DGFLD ; PRF Software Activation Date field # "RTN","DGPFUT2",142,0) N DGFDA ; FDA data array for filer "RTN","DGPFUT2",143,0) N DGERR ; error message array returned from filer "RTN","DGPFUT2",144,0) N DGERRMSG ; error message for display "RTN","DGPFUT2",145,0) N DGPARM ; current internal/external values of field "RTN","DGPFUT2",146,0) ; "RTN","DGPFUT2",147,0) S DGACTDT="SEP 25, 2003" "RTN","DGPFUT2",148,0) S DGIENS="1," "RTN","DGPFUT2",149,0) S DGFLD=1 "RTN","DGPFUT2",150,0) ; "RTN","DGPFUT2",151,0) ; display user message "RTN","DGPFUT2",152,0) W !!,"Updating the PRF SOFTWARE ACTIVATION DATE (#1) field in the PRF PARAMETERS FILE (#26.18) to the value of SEP 25, 2003..." "RTN","DGPFUT2",153,0) ; "RTN","DGPFUT2",154,0) ; checks for necessary programmer variables "RTN","DGPFUT2",155,0) I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D "RTN","DGPFUT2",156,0) . S DGERRMSG="Your programming variables are not set up properly." "RTN","DGPFUT2",157,0) ; "RTN","DGPFUT2",158,0) ; check if activation is not less than the current date "RTN","DGPFUT2",159,0) I '$D(DGERRMSG),DT<3030925 D "RTN","DGPFUT2",160,0) . S DGERRMSG="This file/field update can't be run before the date of SEP 25, 2003 is reached." "RTN","DGPFUT2",161,0) ; "RTN","DGPFUT2",162,0) ; get current activation date from PRF PARAMETERS (#26.18) file "RTN","DGPFUT2",163,0) I '$D(DGERRMSG) D "RTN","DGPFUT2",164,0) . D GETS^DIQ(26.18,"1,",1,"IE","DGPARM","DGERR") "RTN","DGPFUT2",165,0) . ; "RTN","DGPFUT2",166,0) . ; check for errors and inform the user "RTN","DGPFUT2",167,0) . I $D(DGERR) D Q "RTN","DGPFUT2",168,0) . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1)) "RTN","DGPFUT2",169,0) . ; "RTN","DGPFUT2",170,0) . ; check to make sure field is not set already "RTN","DGPFUT2",171,0) . I $G(DGPARM(26.18,"1,",1,"I"))=3030925 D "RTN","DGPFUT2",172,0) . . S DGERRMSG="The date value is already set to SEP 25, 2003." "RTN","DGPFUT2",173,0) ; "RTN","DGPFUT2",174,0) ; now start the (#26.18) filing process "RTN","DGPFUT2",175,0) I '$D(DGERRMSG) D "RTN","DGPFUT2",176,0) . ; "RTN","DGPFUT2",177,0) . ; DELETE activation date before filing since field is uneditable "RTN","DGPFUT2",178,0) . S DGFDA(26.18,DGIENS,1)="@" "RTN","DGPFUT2",179,0) . D FILE^DIE("","DGFDA","DGERR") "RTN","DGPFUT2",180,0) . ; "RTN","DGPFUT2",181,0) . ; check for errors and inform the user "RTN","DGPFUT2",182,0) . I $D(DGERR) D Q "RTN","DGPFUT2",183,0) . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1)) "RTN","DGPFUT2",184,0) . ; "RTN","DGPFUT2",185,0) . ; setup and file the new activation date value (external) "RTN","DGPFUT2",186,0) . S DGFDA(26.18,DGIENS,1)=DGACTDT "RTN","DGPFUT2",187,0) . D FILE^DIE("SE","DGFDA","DGERR") "RTN","DGPFUT2",188,0) . ; "RTN","DGPFUT2",189,0) . ; check for success or errors and inform the user of update status "RTN","DGPFUT2",190,0) . I $D(DGERR) D Q "RTN","DGPFUT2",191,0) . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1)) "RTN","DGPFUT2",192,0) ; "RTN","DGPFUT2",193,0) ; display successful/failure file update - updated field and value "RTN","DGPFUT2",194,0) W !!,$C(7) "RTN","DGPFUT2",195,0) I $D(DGERRMSG) D "RTN","DGPFUT2",196,0) . W "Field could not be updated...",DGERRMSG "RTN","DGPFUT2",197,0) E D "RTN","DGPFUT2",198,0) . W "Field was successfully changed from ",$G(DGPARM(26.18,"1,",1,"E"))," to ",$G(DGFDA(26.18,DGIENS,DGFLD)),"." "RTN","DGPFUT2",199,0) ; "RTN","DGPFUT2",200,0) Q "RTN","DGPFUT2",201,0) ; "RTN","DGPFUT2",202,0) ; "RTN","DGPFUT2",203,0) BLDTFL(DGDFN,DGTFL) ;build array of Treating Facilities "RTN","DGPFUT2",204,0) ; This function builds an array of INSTITUTION (#4) file pointers "RTN","DGPFUT2",205,0) ; that are non-local medical treating facilities for a given patient. "RTN","DGPFUT2",206,0) ; "RTN","DGPFUT2",207,0) ; Input: "RTN","DGPFUT2",208,0) ; DGDFN - pointer to patient in PATIENT (#2) file "RTN","DGPFUT2",209,0) ; "RTN","DGPFUT2",210,0) ; Output: "RTN","DGPFUT2",211,0) ; Function value - 1 on results returned; 0 on failure "RTN","DGPFUT2",212,0) ; DGTFL - array of treating facility INSTITUTION (#4) file pointerS "RTN","DGPFUT2",213,0) ; Format: DGTFL(pointer)=date last treated "RTN","DGPFUT2",214,0) N DGSTAT,DGSTATI,DGKEY,DGOUT,DGI,DGSTI,DGIEN,DGDLT "RTN","DGPFUT2",215,0) S DGSTAT=$P($$SITE^VASITE,U,3) "RTN","DGPFUT2",216,0) S DGSTATI=$P($$SITE^VASITE,U) "RTN","DGPFUT2",217,0) S DGKEY=DGDFN_U_"PI"_U_"USVHA"_U_DGSTAT "RTN","DGPFUT2",218,0) D TFL^VAFCTFU2(.DGOUT,DGKEY) "RTN","DGPFUT2",219,0) S DGI="" F S DGI=$O(DGOUT(DGI)) Q:DGI="" D "RTN","DGPFUT2",220,0) . I $P(DGOUT(DGI),U,2)="PI",$P(DGOUT(DGI),U,3)="USVHA" D "RTN","DGPFUT2",221,0) . . I $P(DGOUT(DGI),U,4)="200CRNR" D "RTN","DGPFUT2",222,0) . . . S DGSTI=$$IEN^XUAF4($P(DGOUT(DGI),U,4)) "RTN","DGPFUT2",223,0) . . . S DGIEN=$O(^DGCN(391.91,"AINST",DGSTI,DGDFN,"")) "RTN","DGPFUT2",224,0) . . . Q:DGIEN="" "RTN","DGPFUT2",225,0) . . . S DGDLT=+$P($G(^DGCN(391.91,DGIEN,0)),U,3) "RTN","DGPFUT2",226,0) . . . S DGTFL(DGSTI)=DGDLT "RTN","DGPFUT2",227,0) . . . Q "RTN","DGPFUT2",228,0) . . S DGSTI=$$IEN^XUAF4($P(DGOUT(DGI),U,4)) "RTN","DGPFUT2",229,0) . . ;Q:DGSTI="" "RTN","DGPFUT2",230,0) . . Q:$$GET1^DIQ(4,DGSTI_",",13)="OTHER"!(+$$STA^XUAF4(DGSTI)=200)!(DGSTI=DGSTATI) "RTN","DGPFUT2",231,0) . . S DGIEN=$O(^DGCN(391.91,"AINST",DGSTI,DGDFN,"")) "RTN","DGPFUT2",232,0) . . Q:DGIEN="" "RTN","DGPFUT2",233,0) . . S DGDLT=+$P($G(^DGCN(391.91,DGIEN,0)),U,3) "RTN","DGPFUT2",234,0) . . S DGTFL(DGSTI)=DGDLT ;DG*5.3*1054 only setting entries that are VistAs and PI/USHVA records "RTN","DGPFUT2",235,0) . .; S:DGSTI'=DGSTATI DGTFL(DGSTI)=DGDLT "RTN","DGPFUT2",236,0) Q $S(+$O(DGTFL(0)):1,1:0) "RTN","DGPFUT2",237,0) ; "RTN","DGPFUT2",238,0) ;This subroutine converts the treating facility list returned by $$BLDTFL to "RTN","DGPFUT2",239,0) ;the format expected by XMIT^DGPFHLU6. "RTN","DGPFUT2",240,0) ; "RTN","DGPFUT2",241,0) ;Input: "RTN","DGPFUT2",242,0) ; DGDFN - pointer to the patient in the PATIENT (#2) file "RTN","DGPFUT2",243,0) ;Output: "RTN","DGPFUT2",244,0) ; DGTFL - array in the format DGTFL(#)=station number (not pointer) "RTN","DGPFUT2",245,0) BLDTFL2(DGDFN,DGTFL) ; "RTN","DGPFUT2",246,0) N DGI,DGJ,DGTMP,DGRET "RTN","DGPFUT2",247,0) S DGRET=$$BLDTFL(DGDFN,.DGTMP) "RTN","DGPFUT2",248,0) S DGJ=0 "RTN","DGPFUT2",249,0) S DGI="" F S DGI=$O(DGTMP(DGI)) Q:DGI="" D "RTN","DGPFUT2",250,0) . S DGJ=DGJ+1 "RTN","DGPFUT2",251,0) . S DGTFL(DGJ)=$$STA^XUAF4(DGI) "RTN","DGPFUT2",252,0) Q "VER") 8.0^22.2 "BLD",12494,6) ^938 **END** **END**