- DGPFCNV ;ALB/SCK - PRF CAT II TO CAT I PROCESSING - MAIN;27 JAN 2012
- ;;5.3;Registration;**849,1113**;Aug 13, 1993;Build 10
- ;
- Q ; No direct entry
- ;
- ; Variables in use
- ; DGRUN Processing Run type, R-Report Only, P-Full Processing
- ; DGPARM Local Cat II PRF name stored in DGPF SUICIDE FLAG parameter field
- ; DGPRF Patient Record flag value
- ; DGXTMP TMP global for information storage on processing run
- ;
- EN ;
- N DGRUN,DGERR,DGPARM,DGPRV,DGNFLAG
- ;
- ;
- S DGNFLAG="HIGH RISK FOR SUICIDE"
- I '$$NATFLG(DGNFLAG) D Q ; Check for national flag
- . D ERRMSG("National PRF flag for Suicide Prevention not found")
- I '$$LOCFLG(.DGPARM) D Q ; check for local flag
- . D ERRMSG("Local PRF for Suicide Prevention not found in Parameter File")
- S DGRUN=$$RUNTYP() ; Determine run type, report or process
- Q:"Q"[DGRUN
- D PROCESS(DGRUN,DGPARM,.DGERR)
- Q
- ;
- PROCESS(DGRUN,DGPARM,DGERR) ;
- N DGXTMP,DGPRF,DGRSLT
- ;
- S DGXTMP="^TMP(""DGPFL2N"",$J)"
- K @DGXTMP
- S DGPRF=$$GETVAR(DGPARM,"L")
- I +DGPRF<1 D Q
- . S DGERR="Local Patient Record Flag '"_DGPARM_"' was "_$P(DGPRF,";",2)
- D WAIT^DICD
- D SEARCH(DGPRF,DGRUN,DGXTMP,.DGRSLT)
- D EN^DGPFCNR(.DGRSLT,DGXTMP)
- Q
- ;
- SEARCH(DGPRF,DGRUN,DGXTMP,DGRSLT) ; Begin search for Cat II flags to convert
- N DGIEN,DFN,DGPAT,DGX,DGPRFN,DGCNVT,DGINACT,DGPIEN1
- ;
- F DGX="TOTAL","NEW","ERR","MANUAL","DONE" S DGRSLT(DGX)=0
- ;
- S DFN=0
- F S DFN=$O(^DGPF(26.13,"AFLAG",DGPRF,DFN)) Q:'DFN D
- . S DGI=$O(^DGPF(26.13,"AFLAG",DGPRF,DFN,0))
- . Q:'$$GET1^DIQ(26.13,DGI,.03,"I")
- . S DGRSLT("TOTAL")=DGRSLT("TOTAL")+1
- . I '$$GETPAT^DGPFUT2(DFN,.DGPAT) D Q
- .. S DGRSLT("ERR")=DGRSLT("ERR")+1
- .. S @DGXTMP@("DFN ERROR",DFN)="Unable to retrieve patient information for "_DFN
- . ;
- . I '$$MPIOK^DGPFUT(DFN) D Q
- .. S DGRSLT("ERR")=DGRSLT("ERR")+1
- .. S @DGXTMP@("MPI ERROR",DGPAT("NAME"))="This patient has a local ICN assigned^"_DFN
- . ;
- . S DGPFIEN=$O(^DGPF(26.13,"AFLAG",DGPRF,DFN,0))
- . S DGPRFN=$$GETFLAG^DGPFAPIU(DGNFLAG,"N")
- . S DGPIEN1=$O(^DGPF(26.13,"AFLAG",DGPRFN,DFN,0))
- . I DGPIEN1>0 D Q
- .. I $$GETASGN^DGPFAA(DGPFIEN,.DGPFA)
- .. I +DGPFA("STATUS") D
- ... S DGRSLT("DONE")=DGRSLT("DONE")+1
- ... S @DGXTMP@("FLGASGN",DGPAT("NAME"))="Patient had active National and Local PRF's assigned^"_DFN_"^"_DGPFIEN
- ... I "P"[DGRUN S DGINACT=$$INACT(DGPFIEN) I '$G(DGINACT) D
- .... S DGRSLT("ERR")=DGRSLT("ERR")+1
- .... S @DGXTMP@("ERROR",DGPAT("NAME"))=$P(DGINACT,U,2)
- . ;
- . K DGERR
- . S DGOWNER=0
- . ;I '$$OWNER(DFN,$G(DGPFIEN),.DGOWNER,.DGERR) D Q
- . ;. S DGRSLT("MANUAL")=DGRSLT("MANUAL")+1
- . ;. S @DGXTMP@("MANUAL",DGPAT("NAME"))=DGERR_"^"_DFN
- . ;
- . I "P"[DGRUN D
- .. S DGCNVT=$$CONVERT(DGPFIEN,DGOWNER,DGPRFN)
- .. I +DGCNVT D
- ... S DGRSLT("NEW")=DGRSLT("NEW")+1
- ... S @DGXTMP@("COMPLETE",DGPAT("NAME"))=DFN_"^"_$P(DGCNVT,U,2,3)_"^"_$P(DGCNVT,U,2)
- .. E D
- ... S DGRSLT("ERR")=DGRSLT("ERR")+1
- ... S @DGXTMP@("ERROR",DGPAT("NAME"))=$P(DGCNVT,U,2)_"^"_DFN_"^"_DGPFIEN
- . E D
- .. S DGRSLT("NEW")=DGRSLT("NEW")+1
- .. S @DGXTMP@("PREPROC",DGPAT("NAME"))=DFN_"^"_DGPFIEN
- Q
- ;
- CONVERT(DGPFIEN,DGOWNER,DGPRFN) ;
- N DGRSLT,DGASGN,DGNEW,DGNEWH,DGASGNH,DGPFHIEN,DGRESULT,DGHLRSLT,DGUPDT,DGRDDT
- ;
- I '$$GETASGN^DGPFAA(DGPFIEN,.DGASGN) D G CNVTQ
- . S DGRSLT="0^Unable to to Retrieve PRF Assignment"
- S DGNEW("DFN")=DGASGN("DFN")
- S DGNEW("FLAG")=DGPRFN_"^"_DGNFLAG
- S DGNEW("STATUS")="1^ACTIVE"
- S DGNEW("OWNER")=DGASGN("OWNER") ;DGOWNER
- S DGNEW("ORIGSITE")=$P($$SITE^VASITE,U,1,2)
- ;S DGNEW("REVIEWDT")=$$FMADD^XLFDT($P(DGASGN("REVIEWDT"),U),90)
- D BLDWP(.DGASGN,.DGNEW,"ASGNTXT","NARR")
- ;
- S DGPFHIEN=$$GETLAST^DGPFAAH(DGPFIEN)
- I $$GETHIST^DGPFAAH(DGPFHIEN,.DGASGNH) D
- . S DGNEWH("ACTION")="1^NEW ASSIGNMENT"
- . S DGNEWH("APPRVBY")=DGASGNH("APPRVBY")
- . S DGNEWH("ASSIGN")=DGASGNH("ASSIGN")
- . S DGNEWH("ASSIGNDT")=$$NOW^XLFDT_"^"_$$FMTE^XLFDT($$NOW^XLFDT)
- . S DGNEWH("ENTERBY")=DUZ_"^"_$$GET1^DIQ(200,DUZ,.01)
- . S DGNEWH("ORIGFAC")=+$$SITE^VASITE
- . S DGNEWH("TIULINK")="^"
- . D BLDWP("",.DGNEWH,"HSTNEW","COMMENT")
- ;
- ; Set Review Date
- I $$FMDIFF^XLFDT(+$G(DGASGN("REVIEWDT")),+$G(DGASGNH("ASSIGNDT")),1)>90 D
- . S DGNEW("REVIEWDT")=$$FMADD^XLFDT($P(DGASGNH("ASSIGNDT"),".",1),90)
- . S DGNEW("REVIEWDT")=DGNEW("REVIEWDT")_"^"_$$FMTE^XLFDT(+DGNEW("REVIEWDT"))
- . S DGX=$O(DGNEW("NARR",99999),-1),DGX=DGX+1
- . S DGNEW("NARR",DGX,0)="Original Review Date from Local PRF: "_$P($G(DGASGN("REVIEWDT")),U,2)
- E D
- . S DGNEW("REVIEWDT")=DGASGN("REVIEWDT")
- ;
- S DGRESULT=$$STOALL^DGPFAA(.DGNEW,.DGNEWH,.DGERR)
- I +$G(DGRESULT) D
- . S DGRSLT=1_"^"_DGRESULT
- . S:$$PROD^XUPROD() DGHLRSLT=$$SNDORU^DGPFHLS(+$G(DGRESULT))
- . S DGUPDT=$$INACT(DGPFIEN)
- . I '+$G(DGUPDT) D Q
- .. D SNDERR^DGPFCNR(DGUPDT,DGPFIEN,.DGASGN)
- E D
- . S DGRSLT="0^An error occurred when trying to file assignment/history"
- CNVTQ ;
- Q $G(DGRSLT)
- ;
- INACT(DGPFIEN) ; Inactivate cat II flag
- N DGPFA,DGPFAH,DGRSLT,DGRESULT
- ;
- I '$$LOCK^DGPFAA3(DGPFIEN) D G INACTQ
- . S DGRSLT="0^Unable to lock local PRF assignment for edit^"
- I '$$GETASGN^DGPFAA(DGPFIEN,.DGPFA) D G INACTQ
- . S DGRSLT="0^Unable to retrieve local PRF assignment for edit^"
- ;
- S DGPFA("STATUS")=0
- S DGPFA("REVIEWDT")=""
- S DGPFAH("ACTION")=3
- S DGPFAH("ASSIGNDT")=$$NOW^XLFDT()
- S DGPFAH("ENTERBY")=DUZ
- S DGPFAH("APPRVBY")=DUZ
- D BLDWP("",.DGPFAH,"HSTOLD","COMMENT")
- ;
- S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
- I '+$G(DGRESULT) S DGRSLT="0^Error: "_$S($G(DGERR)]"":DGERR,1:"Unable to file updated assignment")
- E S DGRSLT=1
- INACTQ ;
- Q DGRSLT
- ;
- OWNER(DFN,DGPFIEN,DGOWNER,DGERR) ; Determine owning site using previous owning site, current site and CMOR
- N DGRSLT,DGIEN,DGX,DGCMOR,DGSITE,DGTFL
- ;
- S DGOWNER=$$GET1^DIQ(26.13,DGPFIEN,.04,"I")
- D BLDTFL^DGPFUT2(DFN,.DGTFL)
- S DGCMOR=+$$HL7CMOR^MPIF001(DFN,"^")
- ;
- I DGCMOR>0 D ; CMOR Found
- . I $D(DGTFL)<10 S DGOWNER=DGCMOR,DGRSLT=1 Q ; No TF List found
- . I $D(DGTFL(+DGCMOR)) S DGOWNER=+DGCMOR,DGRSLT=1 Q ; CMOR found on TF List
- . S DGERR="CMOR is not one of the known TF's",DGRSLT=0
- . ;
- E D ; No CMOR found
- . I $D(DGTFL)<10 S DGRSLT=1 Q ; No TF List found
- . S DGSITE=+$$SITE^VASITE
- . I $D(DGTFL(DGSITE)) S DGOWNER=DGSITE,DGRSLT=1 Q ; Current site found on TF List
- . S DGERR="No CMOR found, site does not match known TF",DGRSLT=0
- Q DGRSLT
- ;
- NATFLG(DGNFLAG) ; Check for New national flag
- N DGRSLT
- ;
- S DGRSLT=0
- I $D(^DGPF(26.15,"B",DGNFLAG)) S DGRSLT=1
- Q DGRSLT
- ;
- LOCFLG(DGPARM) ; Retrieve current cat II flag from parameters
- N DGRSLT
- ;
- S DGPARM=$$GET^XPAR("ALL","DGPF SUICIDE FLAG")
- S DGRSLT=0
- I DGPARM]"" S DGRSLT=1
- Q DGRSLT
- ;
- RUNTYP() ;
- N DGRSLT,DIR,X,Y,DIRUT,DGDISPLAY,DGX
- ;
- S DGDISPLAY(1)="This option can be run in a report only mode which will provide a report "
- S DGDISPLAY(2)="of what actions the local-to-national processing will perform. Enter 'R' "
- S DGDISPLAY(3)="to run the Report Only mode, or 'P' to begin the local-to-national PRF "
- S DGDISPLAY(4)="processing."
- W !
- F DGX=1:1:4 W !,DGDISPLAY(DGX)
- ;
- S DIR(0)="SO^R:Report Only;P:Process Local-to-National"
- S DIR("A")="Select which mode to run"
- S DIR("B")="R"
- M DIR("?")=DGDISPLAY
- S DIR("?")="Please select either 'R' to run the pre-report or 'P' to commence processing"
- S DIR("?",5)=""
- D ^DIR K DIR S:$D(DIRUT) Y="Q"
- S DGRSLT=Y
- Q DGRSLT
- ;
- ERRMSG(DGERR) ;
- W !!,?3,DGERR,!!
- Q
- ;
- GETVAR(DGPARMDF,DGCAT) ;
- Q $$GETFLAG^DGPFAPIU(DGPARMDF,DGCAT)
- ;
- BLDWP(DGASGN,DGNEW,DGPFTAG,DGSUB) ; Build word processing fields for assignment and assignment history entries
- N DGI,DGI1,DGTEXT2,DGLAST,DGUSER
- ;
- F DGI=1:1 Q:$P($T(@DGPFTAG+DGI),";;",2)="QUIT"!(DGI>10) D
- . S DGNEW(DGSUB,DGI,0)=$P($T(@DGPFTAG+DGI),";;",2)
- ;
- S DGI=0 ; Insert new comment into top of WP field
- F S DGI=$O(DGNEW(DGSUB,DGI)) Q:'DGI D
- . S DGLAST=DGI
- . I DGNEW(DGSUB,DGI,0)["<DT>" K DGTEXT2 D
- .. S DGTEXT2=$P(DGNEW(DGSUB,DGI,0),"<DT>")_$$FMTE^XLFDT($$NOW^XLFDT)_$P(DGNEW(DGSUB,DGI,0),"<DT>",2)
- .. S DGNEW(DGSUB,DGI,0)=DGTEXT2
- . I DGNEW(DGSUB,DGI,0)["<USER>" K DGTEXT2 D
- .. S DGUSER=$S($G(DUZ)>0:$$GET1^DIQ(200,DUZ,.01),1:"POSTMASTER")
- .. S DGTEXT2=$P(DGNEW(DGSUB,DGI,0),"<USER>")_DGUSER_$P(DGNEW(DGSUB,DGI,0),"<USER>",2)
- .. S DGNEW(DGSUB,DGI,0)=DGTEXT2
- . I DGNEW(DGSUB,DGI,0)["<FLAG>" K DGTEXT2 D
- .. S DGTEXT2=$P(DGNEW(DGSUB,DGI,0),"<FLAG>")_$G(DGPARM)_$P(DGNEW(DGSUB,DGI,0),"<FLAG>",2)
- .. S DGNEW(DGSUB,DGI,0)=DGTEXT2
- ;
- ; Add old narrative text after new inserted comment.
- Q:$D(DGASGN)<10
- S DGI1=0,DGLAST=+$G(DGLAST)+1
- F S DGI1=$O(DGASGN(DGSUB,DGI1)) Q:'DGI1 D
- . S DGNEW(DGSUB,DGLAST,0)=DGASGN(DGSUB,DGI1,0)
- . S DGLAST=DGLAST+1
- Q
- ;
- ASGNTXT ; Narrative text for PRF assignment created by auto-conversion
- ;;This national PRF entry was auto-created on <DT>, by the
- ;;'Convert Local HRMH PRF to National' option, run by <USER>.
- ;;The fields are based on the local PRF <FLAG> which was
- ;;inactivated by the auto conversion.
- ;;QUIT
- Q
- ;
- HSTOLD ; Inactivated cat2 assignment history status text
- ;;This local PRF entry was inactivated by the 'Convert Local HRMH
- ;;PRF to National' option run on <DT> by <USER>. A new
- ;;national HIGH RISK FOR SUICIDE PRF was created using the
- ;;information in this local PRF entry
- ;;QUIT
- Q
- ;
- ALTHTXT ; Inactivated cat2 assignment history text for cat1 conversion at another
- ;;Since a national HIGH RISK FOR SUICIDE PRF entry has been activated
- ;;by another site in VistA, this local PRF entry was inactivated by
- ;;the 'Convert Local HRMH PRF to National' option, run on <DT>
- ;;by <USER>.
- ;;QUIT
- Q
- ;
- HSTNEW ;
- ;;New assignment for national PRF entry auto-created on <DT>,
- ;;by the 'Convert Local HRMH PRF to National' option.
- ;;QUIT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFCNV 9849 printed Jan 18, 2025@03:48:13 Page 2
- DGPFCNV ;ALB/SCK - PRF CAT II TO CAT I PROCESSING - MAIN;27 JAN 2012
- +1 ;;5.3;Registration;**849,1113**;Aug 13, 1993;Build 10
- +2 ;
- +3 ; No direct entry
- QUIT
- +4 ;
- +5 ; Variables in use
- +6 ; DGRUN Processing Run type, R-Report Only, P-Full Processing
- +7 ; DGPARM Local Cat II PRF name stored in DGPF SUICIDE FLAG parameter field
- +8 ; DGPRF Patient Record flag value
- +9 ; DGXTMP TMP global for information storage on processing run
- +10 ;
- EN ;
- +1 NEW DGRUN,DGERR,DGPARM,DGPRV,DGNFLAG
- +2 ;
- +3 ;
- +4 SET DGNFLAG="HIGH RISK FOR SUICIDE"
- +5 ; Check for national flag
- IF '$$NATFLG(DGNFLAG)
- Begin DoDot:1
- +6 DO ERRMSG("National PRF flag for Suicide Prevention not found")
- End DoDot:1
- QUIT
- +7 ; check for local flag
- IF '$$LOCFLG(.DGPARM)
- Begin DoDot:1
- +8 DO ERRMSG("Local PRF for Suicide Prevention not found in Parameter File")
- End DoDot:1
- QUIT
- +9 ; Determine run type, report or process
- SET DGRUN=$$RUNTYP()
- +10 if "Q"[DGRUN
- QUIT
- +11 DO PROCESS(DGRUN,DGPARM,.DGERR)
- +12 QUIT
- +13 ;
- PROCESS(DGRUN,DGPARM,DGERR) ;
- +1 NEW DGXTMP,DGPRF,DGRSLT
- +2 ;
- +3 SET DGXTMP="^TMP(""DGPFL2N"",$J)"
- +4 KILL @DGXTMP
- +5 SET DGPRF=$$GETVAR(DGPARM,"L")
- +6 IF +DGPRF<1
- Begin DoDot:1
- +7 SET DGERR="Local Patient Record Flag '"_DGPARM_"' was "_$PIECE(DGPRF,";",2)
- End DoDot:1
- QUIT
- +8 DO WAIT^DICD
- +9 DO SEARCH(DGPRF,DGRUN,DGXTMP,.DGRSLT)
- +10 DO EN^DGPFCNR(.DGRSLT,DGXTMP)
- +11 QUIT
- +12 ;
- SEARCH(DGPRF,DGRUN,DGXTMP,DGRSLT) ; Begin search for Cat II flags to convert
- +1 NEW DGIEN,DFN,DGPAT,DGX,DGPRFN,DGCNVT,DGINACT,DGPIEN1
- +2 ;
- +3 FOR DGX="TOTAL","NEW","ERR","MANUAL","DONE"
- SET DGRSLT(DGX)=0
- +4 ;
- +5 SET DFN=0
- +6 FOR
- SET DFN=$ORDER(^DGPF(26.13,"AFLAG",DGPRF,DFN))
- if 'DFN
- QUIT
- Begin DoDot:1
- +7 SET DGI=$ORDER(^DGPF(26.13,"AFLAG",DGPRF,DFN,0))
- +8 if '$$GET1^DIQ(26.13,DGI,.03,"I")
- QUIT
- +9 SET DGRSLT("TOTAL")=DGRSLT("TOTAL")+1
- +10 IF '$$GETPAT^DGPFUT2(DFN,.DGPAT)
- Begin DoDot:2
- +11 SET DGRSLT("ERR")=DGRSLT("ERR")+1
- +12 SET @DGXTMP@("DFN ERROR",DFN)="Unable to retrieve patient information for "_DFN
- End DoDot:2
- QUIT
- +13 ;
- +14 IF '$$MPIOK^DGPFUT(DFN)
- Begin DoDot:2
- +15 SET DGRSLT("ERR")=DGRSLT("ERR")+1
- +16 SET @DGXTMP@("MPI ERROR",DGPAT("NAME"))="This patient has a local ICN assigned^"_DFN
- End DoDot:2
- QUIT
- +17 ;
- +18 SET DGPFIEN=$ORDER(^DGPF(26.13,"AFLAG",DGPRF,DFN,0))
- +19 SET DGPRFN=$$GETFLAG^DGPFAPIU(DGNFLAG,"N")
- +20 SET DGPIEN1=$ORDER(^DGPF(26.13,"AFLAG",DGPRFN,DFN,0))
- +21 IF DGPIEN1>0
- Begin DoDot:2
- +22 IF $$GETASGN^DGPFAA(DGPFIEN,.DGPFA)
- +23 IF +DGPFA("STATUS")
- Begin DoDot:3
- +24 SET DGRSLT("DONE")=DGRSLT("DONE")+1
- +25 SET @DGXTMP@("FLGASGN",DGPAT("NAME"))="Patient had active National and Local PRF's assigned^"_DFN_"^"_DGPFIEN
- +26 IF "P"[DGRUN
- SET DGINACT=$$INACT(DGPFIEN)
- IF '$GET(DGINACT)
- Begin DoDot:4
- +27 SET DGRSLT("ERR")=DGRSLT("ERR")+1
- +28 SET @DGXTMP@("ERROR",DGPAT("NAME"))=$PIECE(DGINACT,U,2)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- QUIT
- +29 ;
- +30 KILL DGERR
- +31 SET DGOWNER=0
- +32 ;I '$$OWNER(DFN,$G(DGPFIEN),.DGOWNER,.DGERR) D Q
- +33 ;. S DGRSLT("MANUAL")=DGRSLT("MANUAL")+1
- +34 ;. S @DGXTMP@("MANUAL",DGPAT("NAME"))=DGERR_"^"_DFN
- +35 ;
- +36 IF "P"[DGRUN
- Begin DoDot:2
- +37 SET DGCNVT=$$CONVERT(DGPFIEN,DGOWNER,DGPRFN)
- +38 IF +DGCNVT
- Begin DoDot:3
- +39 SET DGRSLT("NEW")=DGRSLT("NEW")+1
- +40 SET @DGXTMP@("COMPLETE",DGPAT("NAME"))=DFN_"^"_$PIECE(DGCNVT,U,2,3)_"^"_$PIECE(DGCNVT,U,2)
- End DoDot:3
- +41 IF '$TEST
- Begin DoDot:3
- +42 SET DGRSLT("ERR")=DGRSLT("ERR")+1
- +43 SET @DGXTMP@("ERROR",DGPAT("NAME"))=$PIECE(DGCNVT,U,2)_"^"_DFN_"^"_DGPFIEN
- End DoDot:3
- End DoDot:2
- +44 IF '$TEST
- Begin DoDot:2
- +45 SET DGRSLT("NEW")=DGRSLT("NEW")+1
- +46 SET @DGXTMP@("PREPROC",DGPAT("NAME"))=DFN_"^"_DGPFIEN
- End DoDot:2
- End DoDot:1
- +47 QUIT
- +48 ;
- CONVERT(DGPFIEN,DGOWNER,DGPRFN) ;
- +1 NEW DGRSLT,DGASGN,DGNEW,DGNEWH,DGASGNH,DGPFHIEN,DGRESULT,DGHLRSLT,DGUPDT,DGRDDT
- +2 ;
- +3 IF '$$GETASGN^DGPFAA(DGPFIEN,.DGASGN)
- Begin DoDot:1
- +4 SET DGRSLT="0^Unable to to Retrieve PRF Assignment"
- End DoDot:1
- GOTO CNVTQ
- +5 SET DGNEW("DFN")=DGASGN("DFN")
- +6 SET DGNEW("FLAG")=DGPRFN_"^"_DGNFLAG
- +7 SET DGNEW("STATUS")="1^ACTIVE"
- +8 ;DGOWNER
- SET DGNEW("OWNER")=DGASGN("OWNER")
- +9 SET DGNEW("ORIGSITE")=$PIECE($$SITE^VASITE,U,1,2)
- +10 ;S DGNEW("REVIEWDT")=$$FMADD^XLFDT($P(DGASGN("REVIEWDT"),U),90)
- +11 DO BLDWP(.DGASGN,.DGNEW,"ASGNTXT","NARR")
- +12 ;
- +13 SET DGPFHIEN=$$GETLAST^DGPFAAH(DGPFIEN)
- +14 IF $$GETHIST^DGPFAAH(DGPFHIEN,.DGASGNH)
- Begin DoDot:1
- +15 SET DGNEWH("ACTION")="1^NEW ASSIGNMENT"
- +16 SET DGNEWH("APPRVBY")=DGASGNH("APPRVBY")
- +17 SET DGNEWH("ASSIGN")=DGASGNH("ASSIGN")
- +18 SET DGNEWH("ASSIGNDT")=$$NOW^XLFDT_"^"_$$FMTE^XLFDT($$NOW^XLFDT)
- +19 SET DGNEWH("ENTERBY")=DUZ_"^"_$$GET1^DIQ(200,DUZ,.01)
- +20 SET DGNEWH("ORIGFAC")=+$$SITE^VASITE
- +21 SET DGNEWH("TIULINK")="^"
- +22 DO BLDWP("",.DGNEWH,"HSTNEW","COMMENT")
- End DoDot:1
- +23 ;
- +24 ; Set Review Date
- +25 IF $$FMDIFF^XLFDT(+$GET(DGASGN("REVIEWDT")),+$GET(DGASGNH("ASSIGNDT")),1)>90
- Begin DoDot:1
- +26 SET DGNEW("REVIEWDT")=$$FMADD^XLFDT($PIECE(DGASGNH("ASSIGNDT"),".",1),90)
- +27 SET DGNEW("REVIEWDT")=DGNEW("REVIEWDT")_"^"_$$FMTE^XLFDT(+DGNEW("REVIEWDT"))
- +28 SET DGX=$ORDER(DGNEW("NARR",99999),-1)
- SET DGX=DGX+1
- +29 SET DGNEW("NARR",DGX,0)="Original Review Date from Local PRF: "_$PIECE($GET(DGASGN("REVIEWDT")),U,2)
- End DoDot:1
- +30 IF '$TEST
- Begin DoDot:1
- +31 SET DGNEW("REVIEWDT")=DGASGN("REVIEWDT")
- End DoDot:1
- +32 ;
- +33 SET DGRESULT=$$STOALL^DGPFAA(.DGNEW,.DGNEWH,.DGERR)
- +34 IF +$GET(DGRESULT)
- Begin DoDot:1
- +35 SET DGRSLT=1_"^"_DGRESULT
- +36 if $$PROD^XUPROD()
- SET DGHLRSLT=$$SNDORU^DGPFHLS(+$GET(DGRESULT))
- +37 SET DGUPDT=$$INACT(DGPFIEN)
- +38 IF '+$GET(DGUPDT)
- Begin DoDot:2
- +39 DO SNDERR^DGPFCNR(DGUPDT,DGPFIEN,.DGASGN)
- End DoDot:2
- QUIT
- End DoDot:1
- +40 IF '$TEST
- Begin DoDot:1
- +41 SET DGRSLT="0^An error occurred when trying to file assignment/history"
- End DoDot:1
- CNVTQ ;
- +1 QUIT $GET(DGRSLT)
- +2 ;
- INACT(DGPFIEN) ; Inactivate cat II flag
- +1 NEW DGPFA,DGPFAH,DGRSLT,DGRESULT
- +2 ;
- +3 IF '$$LOCK^DGPFAA3(DGPFIEN)
- Begin DoDot:1
- +4 SET DGRSLT="0^Unable to lock local PRF assignment for edit^"
- End DoDot:1
- GOTO INACTQ
- +5 IF '$$GETASGN^DGPFAA(DGPFIEN,.DGPFA)
- Begin DoDot:1
- +6 SET DGRSLT="0^Unable to retrieve local PRF assignment for edit^"
- End DoDot:1
- GOTO INACTQ
- +7 ;
- +8 SET DGPFA("STATUS")=0
- +9 SET DGPFA("REVIEWDT")=""
- +10 SET DGPFAH("ACTION")=3
- +11 SET DGPFAH("ASSIGNDT")=$$NOW^XLFDT()
- +12 SET DGPFAH("ENTERBY")=DUZ
- +13 SET DGPFAH("APPRVBY")=DUZ
- +14 DO BLDWP("",.DGPFAH,"HSTOLD","COMMENT")
- +15 ;
- +16 SET DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
- +17 IF '+$GET(DGRESULT)
- SET DGRSLT="0^Error: "_$SELECT($GET(DGERR)]"":DGERR,1:"Unable to file updated assignment")
- +18 IF '$TEST
- SET DGRSLT=1
- INACTQ ;
- +1 QUIT DGRSLT
- +2 ;
- OWNER(DFN,DGPFIEN,DGOWNER,DGERR) ; Determine owning site using previous owning site, current site and CMOR
- +1 NEW DGRSLT,DGIEN,DGX,DGCMOR,DGSITE,DGTFL
- +2 ;
- +3 SET DGOWNER=$$GET1^DIQ(26.13,DGPFIEN,.04,"I")
- +4 DO BLDTFL^DGPFUT2(DFN,.DGTFL)
- +5 SET DGCMOR=+$$HL7CMOR^MPIF001(DFN,"^")
- +6 ;
- +7 ; CMOR Found
- IF DGCMOR>0
- Begin DoDot:1
- +8 ; No TF List found
- IF $DATA(DGTFL)<10
- SET DGOWNER=DGCMOR
- SET DGRSLT=1
- QUIT
- +9 ; CMOR found on TF List
- IF $DATA(DGTFL(+DGCMOR))
- SET DGOWNER=+DGCMOR
- SET DGRSLT=1
- QUIT
- +10 SET DGERR="CMOR is not one of the known TF's"
- SET DGRSLT=0
- +11 ;
- End DoDot:1
- +12 ; No CMOR found
- IF '$TEST
- Begin DoDot:1
- +13 ; No TF List found
- IF $DATA(DGTFL)<10
- SET DGRSLT=1
- QUIT
- +14 SET DGSITE=+$$SITE^VASITE
- +15 ; Current site found on TF List
- IF $DATA(DGTFL(DGSITE))
- SET DGOWNER=DGSITE
- SET DGRSLT=1
- QUIT
- +16 SET DGERR="No CMOR found, site does not match known TF"
- SET DGRSLT=0
- End DoDot:1
- +17 QUIT DGRSLT
- +18 ;
- NATFLG(DGNFLAG) ; Check for New national flag
- +1 NEW DGRSLT
- +2 ;
- +3 SET DGRSLT=0
- +4 IF $DATA(^DGPF(26.15,"B",DGNFLAG))
- SET DGRSLT=1
- +5 QUIT DGRSLT
- +6 ;
- LOCFLG(DGPARM) ; Retrieve current cat II flag from parameters
- +1 NEW DGRSLT
- +2 ;
- +3 SET DGPARM=$$GET^XPAR("ALL","DGPF SUICIDE FLAG")
- +4 SET DGRSLT=0
- +5 IF DGPARM]""
- SET DGRSLT=1
- +6 QUIT DGRSLT
- +7 ;
- RUNTYP() ;
- +1 NEW DGRSLT,DIR,X,Y,DIRUT,DGDISPLAY,DGX
- +2 ;
- +3 SET DGDISPLAY(1)="This option can be run in a report only mode which will provide a report "
- +4 SET DGDISPLAY(2)="of what actions the local-to-national processing will perform. Enter 'R' "
- +5 SET DGDISPLAY(3)="to run the Report Only mode, or 'P' to begin the local-to-national PRF "
- +6 SET DGDISPLAY(4)="processing."
- +7 WRITE !
- +8 FOR DGX=1:1:4
- WRITE !,DGDISPLAY(DGX)
- +9 ;
- +10 SET DIR(0)="SO^R:Report Only;P:Process Local-to-National"
- +11 SET DIR("A")="Select which mode to run"
- +12 SET DIR("B")="R"
- +13 MERGE DIR("?")=DGDISPLAY
- +14 SET DIR("?")="Please select either 'R' to run the pre-report or 'P' to commence processing"
- +15 SET DIR("?",5)=""
- +16 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET Y="Q"
- +17 SET DGRSLT=Y
- +18 QUIT DGRSLT
- +19 ;
- ERRMSG(DGERR) ;
- +1 WRITE !!,?3,DGERR,!!
- +2 QUIT
- +3 ;
- GETVAR(DGPARMDF,DGCAT) ;
- +1 QUIT $$GETFLAG^DGPFAPIU(DGPARMDF,DGCAT)
- +2 ;
- BLDWP(DGASGN,DGNEW,DGPFTAG,DGSUB) ; Build word processing fields for assignment and assignment history entries
- +1 NEW DGI,DGI1,DGTEXT2,DGLAST,DGUSER
- +2 ;
- +3 FOR DGI=1:1
- if $PIECE($TEXT(@DGPFTAG+DGI),";;",2)="QUIT"!(DGI>10)
- QUIT
- Begin DoDot:1
- +4 SET DGNEW(DGSUB,DGI,0)=$PIECE($TEXT(@DGPFTAG+DGI),";;",2)
- End DoDot:1
- +5 ;
- +6 ; Insert new comment into top of WP field
- SET DGI=0
- +7 FOR
- SET DGI=$ORDER(DGNEW(DGSUB,DGI))
- if 'DGI
- QUIT
- Begin DoDot:1
- +8 SET DGLAST=DGI
- +9 IF DGNEW(DGSUB,DGI,0)["<DT>"
- KILL DGTEXT2
- Begin DoDot:2
- +10 SET DGTEXT2=$PIECE(DGNEW(DGSUB,DGI,0),"<DT>")_$$FMTE^XLFDT($$NOW^XLFDT)_$P(DGNEW(DGSUB,DGI,0),"<DT>",2)
- +11 SET DGNEW(DGSUB,DGI,0)=DGTEXT2
- End DoDot:2
- +12 IF DGNEW(DGSUB,DGI,0)["<USER>"
- KILL DGTEXT2
- Begin DoDot:2
- +13 SET DGUSER=$SELECT($GET(DUZ)>0:$$GET1^DIQ(200,DUZ,.01),1:"POSTMASTER")
- +14 SET DGTEXT2=$PIECE(DGNEW(DGSUB,DGI,0),"<USER>")_DGUSER_$PIECE(DGNEW(DGSUB,DGI,0),"<USER>",2)
- +15 SET DGNEW(DGSUB,DGI,0)=DGTEXT2
- End DoDot:2
- +16 IF DGNEW(DGSUB,DGI,0)["<FLAG>"
- KILL DGTEXT2
- Begin DoDot:2
- +17 SET DGTEXT2=$PIECE(DGNEW(DGSUB,DGI,0),"<FLAG>")_$GET(DGPARM)_$PIECE(DGNEW(DGSUB,DGI,0),"<FLAG>",2)
- +18 SET DGNEW(DGSUB,DGI,0)=DGTEXT2
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 ; Add old narrative text after new inserted comment.
- +21 if $DATA(DGASGN)<10
- QUIT
- +22 SET DGI1=0
- SET DGLAST=+$GET(DGLAST)+1
- +23 FOR
- SET DGI1=$ORDER(DGASGN(DGSUB,DGI1))
- if 'DGI1
- QUIT
- Begin DoDot:1
- +24 SET DGNEW(DGSUB,DGLAST,0)=DGASGN(DGSUB,DGI1,0)
- +25 SET DGLAST=DGLAST+1
- End DoDot:1
- +26 QUIT
- +27 ;
- ASGNTXT ; Narrative text for PRF assignment created by auto-conversion
- +1 ;;This national PRF entry was auto-created on <DT>, by the
- +2 ;;'Convert Local HRMH PRF to National' option, run by <USER>.
- +3 ;;The fields are based on the local PRF <FLAG> which was
- +4 ;;inactivated by the auto conversion.
- +5 ;;QUIT
- +6 QUIT
- +7 ;
- HSTOLD ; Inactivated cat2 assignment history status text
- +1 ;;This local PRF entry was inactivated by the 'Convert Local HRMH
- +2 ;;PRF to National' option run on <DT> by <USER>. A new
- +3 ;;national HIGH RISK FOR SUICIDE PRF was created using the
- +4 ;;information in this local PRF entry
- +5 ;;QUIT
- +6 QUIT
- +7 ;
- ALTHTXT ; Inactivated cat2 assignment history text for cat1 conversion at another
- +1 ;;Since a national HIGH RISK FOR SUICIDE PRF entry has been activated
- +2 ;;by another site in VistA, this local PRF entry was inactivated by
- +3 ;;the 'Convert Local HRMH PRF to National' option, run on <DT>
- +4 ;;by <USER>.
- +5 ;;QUIT
- +6 QUIT
- +7 ;
- HSTNEW ;
- +1 ;;New assignment for national PRF entry auto-created on <DT>,
- +2 ;;by the 'Convert Local HRMH PRF to National' option.
- +3 ;;QUIT
- +4 QUIT