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 Dec 13, 2024@02:47:32 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
