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

DGPFCNV.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q ; No direct entry
  1. ;
  1. ; Variables in use
  1. ; DGRUN Processing Run type, R-Report Only, P-Full Processing
  1. ; DGPARM Local Cat II PRF name stored in DGPF SUICIDE FLAG parameter field
  1. ; DGPRF Patient Record flag value
  1. ; DGXTMP TMP global for information storage on processing run
  1. ;
  1. EN ;
  1. N DGRUN,DGERR,DGPARM,DGPRV,DGNFLAG
  1. ;
  1. ;
  1. S DGNFLAG="HIGH RISK FOR SUICIDE"
  1. I '$$NATFLG(DGNFLAG) D Q ; Check for national flag
  1. . D ERRMSG("National PRF flag for Suicide Prevention not found")
  1. I '$$LOCFLG(.DGPARM) D Q ; check for local flag
  1. . D ERRMSG("Local PRF for Suicide Prevention not found in Parameter File")
  1. S DGRUN=$$RUNTYP() ; Determine run type, report or process
  1. Q:"Q"[DGRUN
  1. D PROCESS(DGRUN,DGPARM,.DGERR)
  1. Q
  1. ;
  1. PROCESS(DGRUN,DGPARM,DGERR) ;
  1. N DGXTMP,DGPRF,DGRSLT
  1. ;
  1. S DGXTMP="^TMP(""DGPFL2N"",$J)"
  1. K @DGXTMP
  1. S DGPRF=$$GETVAR(DGPARM,"L")
  1. I +DGPRF<1 D Q
  1. . S DGERR="Local Patient Record Flag '"_DGPARM_"' was "_$P(DGPRF,";",2)
  1. D WAIT^DICD
  1. D SEARCH(DGPRF,DGRUN,DGXTMP,.DGRSLT)
  1. D EN^DGPFCNR(.DGRSLT,DGXTMP)
  1. Q
  1. ;
  1. N DGIEN,DFN,DGPAT,DGX,DGPRFN,DGCNVT,DGINACT,DGPIEN1
  1. ;
  1. F DGX="TOTAL","NEW","ERR","MANUAL","DONE" S DGRSLT(DGX)=0
  1. ;
  1. S DFN=0
  1. F S DFN=$O(^DGPF(26.13,"AFLAG",DGPRF,DFN)) Q:'DFN D
  1. . S DGI=$O(^DGPF(26.13,"AFLAG",DGPRF,DFN,0))
  1. . Q:'$$GET1^DIQ(26.13,DGI,.03,"I")
  1. . S DGRSLT("TOTAL")=DGRSLT("TOTAL")+1
  1. . I '$$GETPAT^DGPFUT2(DFN,.DGPAT) D Q
  1. .. S DGRSLT("ERR")=DGRSLT("ERR")+1
  1. .. S @DGXTMP@("DFN ERROR",DFN)="Unable to retrieve patient information for "_DFN
  1. . ;
  1. . I '$$MPIOK^DGPFUT(DFN) D Q
  1. .. S DGRSLT("ERR")=DGRSLT("ERR")+1
  1. .. S @DGXTMP@("MPI ERROR",DGPAT("NAME"))="This patient has a local ICN assigned^"_DFN
  1. . ;
  1. . S DGPFIEN=$O(^DGPF(26.13,"AFLAG",DGPRF,DFN,0))
  1. . S DGPRFN=$$GETFLAG^DGPFAPIU(DGNFLAG,"N")
  1. . S DGPIEN1=$O(^DGPF(26.13,"AFLAG",DGPRFN,DFN,0))
  1. . I DGPIEN1>0 D Q
  1. .. I $$GETASGN^DGPFAA(DGPFIEN,.DGPFA)
  1. .. I +DGPFA("STATUS") D
  1. ... S DGRSLT("DONE")=DGRSLT("DONE")+1
  1. ... S @DGXTMP@("FLGASGN",DGPAT("NAME"))="Patient had active National and Local PRF's assigned^"_DFN_"^"_DGPFIEN
  1. ... I "P"[DGRUN S DGINACT=$$INACT(DGPFIEN) I '$G(DGINACT) D
  1. .... S DGRSLT("ERR")=DGRSLT("ERR")+1
  1. .... S @DGXTMP@("ERROR",DGPAT("NAME"))=$P(DGINACT,U,2)
  1. . ;
  1. . K DGERR
  1. . S DGOWNER=0
  1. . ;I '$$OWNER(DFN,$G(DGPFIEN),.DGOWNER,.DGERR) D Q
  1. . ;. S DGRSLT("MANUAL")=DGRSLT("MANUAL")+1
  1. . ;. S @DGXTMP@("MANUAL",DGPAT("NAME"))=DGERR_"^"_DFN
  1. . ;
  1. . I "P"[DGRUN D
  1. .. S DGCNVT=$$CONVERT(DGPFIEN,DGOWNER,DGPRFN)
  1. .. I +DGCNVT D
  1. ... S DGRSLT("NEW")=DGRSLT("NEW")+1
  1. ... S @DGXTMP@("COMPLETE",DGPAT("NAME"))=DFN_"^"_$P(DGCNVT,U,2,3)_"^"_$P(DGCNVT,U,2)
  1. .. E D
  1. ... S DGRSLT("ERR")=DGRSLT("ERR")+1
  1. ... S @DGXTMP@("ERROR",DGPAT("NAME"))=$P(DGCNVT,U,2)_"^"_DFN_"^"_DGPFIEN
  1. . E D
  1. .. S DGRSLT("NEW")=DGRSLT("NEW")+1
  1. .. S @DGXTMP@("PREPROC",DGPAT("NAME"))=DFN_"^"_DGPFIEN
  1. Q
  1. ;
  1. CONVERT(DGPFIEN,DGOWNER,DGPRFN) ;
  1. N DGRSLT,DGASGN,DGNEW,DGNEWH,DGASGNH,DGPFHIEN,DGRESULT,DGHLRSLT,DGUPDT,DGRDDT
  1. ;
  1. I '$$GETASGN^DGPFAA(DGPFIEN,.DGASGN) D G CNVTQ
  1. . S DGRSLT="0^Unable to to Retrieve PRF Assignment"
  1. S DGNEW("DFN")=DGASGN("DFN")
  1. S DGNEW("FLAG")=DGPRFN_"^"_DGNFLAG
  1. S DGNEW("STATUS")="1^ACTIVE"
  1. S DGNEW("OWNER")=DGASGN("OWNER") ;DGOWNER
  1. S DGNEW("ORIGSITE")=$P($$SITE^VASITE,U,1,2)
  1. ;S DGNEW("REVIEWDT")=$$FMADD^XLFDT($P(DGASGN("REVIEWDT"),U),90)
  1. D BLDWP(.DGASGN,.DGNEW,"ASGNTXT","NARR")
  1. ;
  1. S DGPFHIEN=$$GETLAST^DGPFAAH(DGPFIEN)
  1. I $$GETHIST^DGPFAAH(DGPFHIEN,.DGASGNH) D
  1. . S DGNEWH("ACTION")="1^NEW ASSIGNMENT"
  1. . S DGNEWH("APPRVBY")=DGASGNH("APPRVBY")
  1. . S DGNEWH("ASSIGN")=DGASGNH("ASSIGN")
  1. . S DGNEWH("ASSIGNDT")=$$NOW^XLFDT_"^"_$$FMTE^XLFDT($$NOW^XLFDT)
  1. . S DGNEWH("ENTERBY")=DUZ_"^"_$$GET1^DIQ(200,DUZ,.01)
  1. . S DGNEWH("ORIGFAC")=+$$SITE^VASITE
  1. . S DGNEWH("TIULINK")="^"
  1. . D BLDWP("",.DGNEWH,"HSTNEW","COMMENT")
  1. ;
  1. ; Set Review Date
  1. I $$FMDIFF^XLFDT(+$G(DGASGN("REVIEWDT")),+$G(DGASGNH("ASSIGNDT")),1)>90 D
  1. . S DGNEW("REVIEWDT")=$$FMADD^XLFDT($P(DGASGNH("ASSIGNDT"),".",1),90)
  1. . S DGNEW("REVIEWDT")=DGNEW("REVIEWDT")_"^"_$$FMTE^XLFDT(+DGNEW("REVIEWDT"))
  1. . S DGX=$O(DGNEW("NARR",99999),-1),DGX=DGX+1
  1. . S DGNEW("NARR",DGX,0)="Original Review Date from Local PRF: "_$P($G(DGASGN("REVIEWDT")),U,2)
  1. E D
  1. . S DGNEW("REVIEWDT")=DGASGN("REVIEWDT")
  1. ;
  1. S DGRESULT=$$STOALL^DGPFAA(.DGNEW,.DGNEWH,.DGERR)
  1. I +$G(DGRESULT) D
  1. . S DGRSLT=1_"^"_DGRESULT
  1. . S:$$PROD^XUPROD() DGHLRSLT=$$SNDORU^DGPFHLS(+$G(DGRESULT))
  1. . S DGUPDT=$$INACT(DGPFIEN)
  1. . I '+$G(DGUPDT) D Q
  1. .. D SNDERR^DGPFCNR(DGUPDT,DGPFIEN,.DGASGN)
  1. E D
  1. . S DGRSLT="0^An error occurred when trying to file assignment/history"
  1. CNVTQ ;
  1. Q $G(DGRSLT)
  1. ;
  1. INACT(DGPFIEN) ; Inactivate cat II flag
  1. N DGPFA,DGPFAH,DGRSLT,DGRESULT
  1. ;
  1. I '$$LOCK^DGPFAA3(DGPFIEN) D G INACTQ
  1. . S DGRSLT="0^Unable to lock local PRF assignment for edit^"
  1. I '$$GETASGN^DGPFAA(DGPFIEN,.DGPFA) D G INACTQ
  1. . S DGRSLT="0^Unable to retrieve local PRF assignment for edit^"
  1. ;
  1. S DGPFA("STATUS")=0
  1. S DGPFA("REVIEWDT")=""
  1. S DGPFAH("ACTION")=3
  1. S DGPFAH("ASSIGNDT")=$$NOW^XLFDT()
  1. S DGPFAH("ENTERBY")=DUZ
  1. S DGPFAH("APPRVBY")=DUZ
  1. D BLDWP("",.DGPFAH,"HSTOLD","COMMENT")
  1. ;
  1. S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR)
  1. I '+$G(DGRESULT) S DGRSLT="0^Error: "_$S($G(DGERR)]"":DGERR,1:"Unable to file updated assignment")
  1. E S DGRSLT=1
  1. INACTQ ;
  1. Q DGRSLT
  1. ;
  1. OWNER(DFN,DGPFIEN,DGOWNER,DGERR) ; Determine owning site using previous owning site, current site and CMOR
  1. N DGRSLT,DGIEN,DGX,DGCMOR,DGSITE,DGTFL
  1. ;
  1. S DGOWNER=$$GET1^DIQ(26.13,DGPFIEN,.04,"I")
  1. D BLDTFL^DGPFUT2(DFN,.DGTFL)
  1. S DGCMOR=+$$HL7CMOR^MPIF001(DFN,"^")
  1. ;
  1. I DGCMOR>0 D ; CMOR Found
  1. . I $D(DGTFL)<10 S DGOWNER=DGCMOR,DGRSLT=1 Q ; No TF List found
  1. . I $D(DGTFL(+DGCMOR)) S DGOWNER=+DGCMOR,DGRSLT=1 Q ; CMOR found on TF List
  1. . S DGERR="CMOR is not one of the known TF's",DGRSLT=0
  1. . ;
  1. E D ; No CMOR found
  1. . I $D(DGTFL)<10 S DGRSLT=1 Q ; No TF List found
  1. . S DGSITE=+$$SITE^VASITE
  1. . I $D(DGTFL(DGSITE)) S DGOWNER=DGSITE,DGRSLT=1 Q ; Current site found on TF List
  1. . S DGERR="No CMOR found, site does not match known TF",DGRSLT=0
  1. Q DGRSLT
  1. ;
  1. NATFLG(DGNFLAG) ; Check for New national flag
  1. N DGRSLT
  1. ;
  1. S DGRSLT=0
  1. I $D(^DGPF(26.15,"B",DGNFLAG)) S DGRSLT=1
  1. Q DGRSLT
  1. ;
  1. LOCFLG(DGPARM) ; Retrieve current cat II flag from parameters
  1. N DGRSLT
  1. ;
  1. S DGPARM=$$GET^XPAR("ALL","DGPF SUICIDE FLAG")
  1. S DGRSLT=0
  1. I DGPARM]"" S DGRSLT=1
  1. Q DGRSLT
  1. ;
  1. RUNTYP() ;
  1. N DGRSLT,DIR,X,Y,DIRUT,DGDISPLAY,DGX
  1. ;
  1. S DGDISPLAY(1)="This option can be run in a report only mode which will provide a report "
  1. S DGDISPLAY(2)="of what actions the local-to-national processing will perform. Enter 'R' "
  1. S DGDISPLAY(3)="to run the Report Only mode, or 'P' to begin the local-to-national PRF "
  1. S DGDISPLAY(4)="processing."
  1. W !
  1. F DGX=1:1:4 W !,DGDISPLAY(DGX)
  1. ;
  1. S DIR(0)="SO^R:Report Only;P:Process Local-to-National"
  1. S DIR("A")="Select which mode to run"
  1. S DIR("B")="R"
  1. M DIR("?")=DGDISPLAY
  1. S DIR("?")="Please select either 'R' to run the pre-report or 'P' to commence processing"
  1. S DIR("?",5)=""
  1. D ^DIR K DIR S:$D(DIRUT) Y="Q"
  1. S DGRSLT=Y
  1. Q DGRSLT
  1. ;
  1. ERRMSG(DGERR) ;
  1. W !!,?3,DGERR,!!
  1. Q
  1. ;
  1. GETVAR(DGPARMDF,DGCAT) ;
  1. Q $$GETFLAG^DGPFAPIU(DGPARMDF,DGCAT)
  1. ;
  1. BLDWP(DGASGN,DGNEW,DGPFTAG,DGSUB) ; Build word processing fields for assignment and assignment history entries
  1. N DGI,DGI1,DGTEXT2,DGLAST,DGUSER
  1. ;
  1. F DGI=1:1 Q:$P($T(@DGPFTAG+DGI),";;",2)="QUIT"!(DGI>10) D
  1. . S DGNEW(DGSUB,DGI,0)=$P($T(@DGPFTAG+DGI),";;",2)
  1. ;
  1. S DGI=0 ; Insert new comment into top of WP field
  1. F S DGI=$O(DGNEW(DGSUB,DGI)) Q:'DGI D
  1. . S DGLAST=DGI
  1. . I DGNEW(DGSUB,DGI,0)["<DT>" K DGTEXT2 D
  1. .. S DGTEXT2=$P(DGNEW(DGSUB,DGI,0),"<DT>")_$$FMTE^XLFDT($$NOW^XLFDT)_$P(DGNEW(DGSUB,DGI,0),"<DT>",2)
  1. .. S DGNEW(DGSUB,DGI,0)=DGTEXT2
  1. . I DGNEW(DGSUB,DGI,0)["<USER>" K DGTEXT2 D
  1. .. S DGUSER=$S($G(DUZ)>0:$$GET1^DIQ(200,DUZ,.01),1:"POSTMASTER")
  1. .. S DGTEXT2=$P(DGNEW(DGSUB,DGI,0),"<USER>")_DGUSER_$P(DGNEW(DGSUB,DGI,0),"<USER>",2)
  1. .. S DGNEW(DGSUB,DGI,0)=DGTEXT2
  1. . I DGNEW(DGSUB,DGI,0)["<FLAG>" K DGTEXT2 D
  1. .. S DGTEXT2=$P(DGNEW(DGSUB,DGI,0),"<FLAG>")_$G(DGPARM)_$P(DGNEW(DGSUB,DGI,0),"<FLAG>",2)
  1. .. S DGNEW(DGSUB,DGI,0)=DGTEXT2
  1. ;
  1. ; Add old narrative text after new inserted comment.
  1. Q:$D(DGASGN)<10
  1. S DGI1=0,DGLAST=+$G(DGLAST)+1
  1. F S DGI1=$O(DGASGN(DGSUB,DGI1)) Q:'DGI1 D
  1. . S DGNEW(DGSUB,DGLAST,0)=DGASGN(DGSUB,DGI1,0)
  1. . S DGLAST=DGLAST+1
  1. Q
  1. ;
  1. ASGNTXT ; Narrative text for PRF assignment created by auto-conversion
  1. ;;This national PRF entry was auto-created on <DT>, by the
  1. ;;'Convert Local HRMH PRF to National' option, run by <USER>.
  1. ;;The fields are based on the local PRF <FLAG> which was
  1. ;;inactivated by the auto conversion.
  1. ;;QUIT
  1. Q
  1. ;
  1. HSTOLD ; Inactivated cat2 assignment history status text
  1. ;;This local PRF entry was inactivated by the 'Convert Local HRMH
  1. ;;PRF to National' option run on <DT> by <USER>. A new
  1. ;;national HIGH RISK FOR SUICIDE PRF was created using the
  1. ;;information in this local PRF entry
  1. ;;QUIT
  1. Q
  1. ;
  1. ALTHTXT ; Inactivated cat2 assignment history text for cat1 conversion at another
  1. ;;Since a national HIGH RISK FOR SUICIDE PRF entry has been activated
  1. ;;by another site in VistA, this local PRF entry was inactivated by
  1. ;;the 'Convert Local HRMH PRF to National' option, run on <DT>
  1. ;;by <USER>.
  1. ;;QUIT
  1. Q
  1. ;
  1. HSTNEW ;
  1. ;;New assignment for national PRF entry auto-created on <DT>,
  1. ;;by the 'Convert Local HRMH PRF to National' option.
  1. ;;QUIT
  1. Q