- VAFCEHLM ;ALB/JLU,LTL-FILE UTILITIES FOR 391.98 ;12/07/00
- ;;5.3;Registration;**149,255,307,333,477**;Aug 13, 1993
- ;
- ;Reference to VTQ^MPIFSAQ supported by IA #2941
- ;
- EN ; -- main entry point for VAFC EXCPT SUM SCR
- ;fix records stuck in 'being reviewed' status
- S IEN=0 F S IEN=$O(^DGCN(391.98,"AST",5,IEN)) Q:'IEN D ;**255
- . L +^DGCN(391.98,IEN,0):0 I '$T Q ;record is truly being reviewed
- . S XX=$$EDIT^VAFCEHU1(IEN,"AR") ;change record to action required
- . L -^DGCN(391.98,IEN,0)
- L +^DGCN(391.98,"VAFC PDR PURGE"):0 I '$T W $C(7),!!,"The Purge Patient Data Reviews process is currently running." QUIT
- L -^DGCN(391.98,"VAFC PDR PURGE")
- D EN^VALM("VAFC EXCPT SUM SCR")
- Q
- ;
- HDR ; -- header code
- N RGSTRNG
- S RGSTRNG="Review(s) currently on file."
- S VALMHDR(1)=$$CENTER(RGSTRNG)
- Q
- ;
- INIT ; -- init variables and list array
- ;checking for sort variable
- N XQORNOD
- I '$D(VAFCSORT) S VAFCSORT="SN"
- ;
- INIT2 ;enter at this point to reset the screens after editing etc.
- K @VALMAR
- D SORTS^VAFCEHU2(VAFCSORT,VALMAR)
- D FORMAT^VAFCEHU2(VALMAR,.VALMCNT,.VALMQUIT)
- Q
- ;
- HELP ; -- help code
- S X="?",VALMSG="Select patient for detailed display or change sorting"
- D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K @VALMAR,VAFCSORT
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- SACT D HDR
- D INIT
- S VALMBCK="R"
- Q
- ;
- FULL S VALMSG="** = Different, -> = Edited, <UR> = Unresolved" D REVFUL^VAFCEHU2
- S VALMBCK="R"
- Q
- ;
- DIFF S VALMBCK="R"
- Q
- ;
- INQ ; Patient Inquiry ;**255
- N DFN
- S DFN=+$P($G(^DGCN(391.98,IENPDR,0)),"^",1) ;**477
- S VALMBCK=""
- D FULL^VALM1
- D EN^DGRPD
- D PAUSE^VALM1
- S VALMBCK="R"
- Q
- ;
- DISP ; Display Only Query to MPI ;**307
- S VALMBCK=""
- D FULL^VALM1
- S MPIVAR("DFN")=$P(EXCPT,"^",1)
- S MPIVAR("SSN")=$P($G(^DPT(+$P(EXCPT,"^",1),0)),"^",9)
- S MPIVAR("NM")=$P($G(^DPT(+$P(EXCPT,"^",1),0)),"^",1)
- S MPIVAR("DOB")=$P($P($G(^DPT(+$P(EXCPT,"^",1),0)),"^",3),".",1)
- D VTQ^MPIFSAQ(.MPIVAR)
- D PAUSE^VALM1
- S VALMBCK="R"
- K MPIVAR
- Q
- ;
- PDAT ;report to list CMOR, TF's & SUB's ;**333
- N DFN
- S DFN=+$P($G(^DGCN(391.98,IEN,0)),"^",1)
- S VALMBCK=""
- D FULL^VALM1
- D START^VAFCPDAT
- ;D PAUSE^VALM1
- S VALMBCK="R"
- Q
- ;
- CENTER(STRG) ;
- ;
- N LEN,FIL,FIL1
- S LEN=80-$L(STRG)
- S FIL=LEN/2
- S $P(FIL1," ",FIL)=""
- Q FIL1_STRG
- ;
- PDRPRG ;Purge PDRs ;**477
- L +^DGCN(391.98,"VAFC PDR PURGE"):0 I '$T W $C(7),!!,"The Purge Patient Data Reviews process is currently running." Q
- L -^DGCN(391.98,"VAFC PDR PURGE")
- N TDATE,MAXDT,PDATE,X1,X2,X,Y
- S NDATE=""
- D NOW^%DTC S TDATE=X
- S X1=TDATE,X2=-30 D C^%DTC
- S (Y,MAXDT)=X D DD^%DT S PDATE=Y
- S DIR("?")="Enter a date at least 30 days in the past."
- S DIR("A")="Purge all Patient Data Reviews prior to "
- S DIR("B")=PDATE,DIR(0)="DAO^:"_MAXDT_":EPX" D ^DIR K DIR Q:$D(DIRUT)
- S NDATE=Y
- S DIR(0)="YA",DIR("B")="NO"
- S DIR("A")="Are you sure you want to purge Patient Data Reviews? " D ^DIR K DIR Q:$D(DIRUT)
- Q:Y=0
- ;
- N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTREQ
- S ZTRTN="QPRG^VAFCEHLM",ZTDESC="PURGE PATIENT DATA REVIEWS OVER 30 DAYS OLD OR X DAYS OLD AS SPECIFIED BY USER."
- D NOW^%DTC
- S ZTIO="",ZTDTH=%
- I $D(DUZ) S ZTSAVE("DUZ")=DUZ,ZTSAVE("NDATE")=NDATE
- D ^%ZTLOAD
- W !!?15,"Patient Data Review Purge Queued, Task #"_ZTSK
- D HOME^%ZIS K IO("Q")
- Q
- QPRG ;
- I $D(ZTQUEUED) S ZTREQ="@"
- L +^DGCN(391.98,"VAFC PDR PURGE"):0 I '$T Q
- N PDR,EVTDT,ERR S PDR=0,EVTDT=""
- F S EVTDT=$O(^DGCN(391.98,"EVT",EVTDT)) Q:EVTDT>NDATE D
- . F S PDR=$O(^DGCN(391.98,"EVT",EVTDT,PDR)) Q:'PDR D
- .. S ERR=$$DELEXCPT^VAFCEHU1(PDR)
- L -^DGCN(391.98,"VAFC PDR PURGE")
- K NDATE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCEHLM 3650 printed Jan 18, 2025@04:02:19 Page 2
- VAFCEHLM ;ALB/JLU,LTL-FILE UTILITIES FOR 391.98 ;12/07/00
- +1 ;;5.3;Registration;**149,255,307,333,477**;Aug 13, 1993
- +2 ;
- +3 ;Reference to VTQ^MPIFSAQ supported by IA #2941
- +4 ;
- EN ; -- main entry point for VAFC EXCPT SUM SCR
- +1 ;fix records stuck in 'being reviewed' status
- +2 ;**255
- SET IEN=0
- FOR
- SET IEN=$ORDER(^DGCN(391.98,"AST",5,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +3 ;record is truly being reviewed
- LOCK +^DGCN(391.98,IEN,0):0
- IF '$TEST
- QUIT
- +4 ;change record to action required
- SET XX=$$EDIT^VAFCEHU1(IEN,"AR")
- +5 LOCK -^DGCN(391.98,IEN,0)
- End DoDot:1
- +6 LOCK +^DGCN(391.98,"VAFC PDR PURGE"):0
- IF '$TEST
- WRITE $CHAR(7),!!,"The Purge Patient Data Reviews process is currently running."
- QUIT
- +7 LOCK -^DGCN(391.98,"VAFC PDR PURGE")
- +8 DO EN^VALM("VAFC EXCPT SUM SCR")
- +9 QUIT
- +10 ;
- HDR ; -- header code
- +1 NEW RGSTRNG
- +2 SET RGSTRNG="Review(s) currently on file."
- +3 SET VALMHDR(1)=$$CENTER(RGSTRNG)
- +4 QUIT
- +5 ;
- INIT ; -- init variables and list array
- +1 ;checking for sort variable
- +2 NEW XQORNOD
- +3 IF '$DATA(VAFCSORT)
- SET VAFCSORT="SN"
- +4 ;
- INIT2 ;enter at this point to reset the screens after editing etc.
- +1 KILL @VALMAR
- +2 DO SORTS^VAFCEHU2(VAFCSORT,VALMAR)
- +3 DO FORMAT^VAFCEHU2(VALMAR,.VALMCNT,.VALMQUIT)
- +4 QUIT
- +5 ;
- HELP ; -- help code
- +1 SET X="?"
- SET VALMSG="Select patient for detailed display or change sorting"
- +2 DO DISP^XQORM1
- WRITE !!
- +3 QUIT
- +4 ;
- EXIT ; -- exit code
- +1 KILL @VALMAR,VAFCSORT
- +2 QUIT
- +3 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- SACT DO HDR
- +1 DO INIT
- +2 SET VALMBCK="R"
- +3 QUIT
- +4 ;
- FULL SET VALMSG="** = Different, -> = Edited, <UR> = Unresolved"
- DO REVFUL^VAFCEHU2
- +1 SET VALMBCK="R"
- +2 QUIT
- +3 ;
- DIFF SET VALMBCK="R"
- +1 QUIT
- +2 ;
- INQ ; Patient Inquiry ;**255
- +1 NEW DFN
- +2 ;**477
- SET DFN=+$PIECE($GET(^DGCN(391.98,IENPDR,0)),"^",1)
- +3 SET VALMBCK=""
- +4 DO FULL^VALM1
- +5 DO EN^DGRPD
- +6 DO PAUSE^VALM1
- +7 SET VALMBCK="R"
- +8 QUIT
- +9 ;
- DISP ; Display Only Query to MPI ;**307
- +1 SET VALMBCK=""
- +2 DO FULL^VALM1
- +3 SET MPIVAR("DFN")=$PIECE(EXCPT,"^",1)
- +4 SET MPIVAR("SSN")=$PIECE($GET(^DPT(+$PIECE(EXCPT,"^",1),0)),"^",9)
- +5 SET MPIVAR("NM")=$PIECE($GET(^DPT(+$PIECE(EXCPT,"^",1),0)),"^",1)
- +6 SET MPIVAR("DOB")=$PIECE($PIECE($GET(^DPT(+$PIECE(EXCPT,"^",1),0)),"^",3),".",1)
- +7 DO VTQ^MPIFSAQ(.MPIVAR)
- +8 DO PAUSE^VALM1
- +9 SET VALMBCK="R"
- +10 KILL MPIVAR
- +11 QUIT
- +12 ;
- PDAT ;report to list CMOR, TF's & SUB's ;**333
- +1 NEW DFN
- +2 SET DFN=+$PIECE($GET(^DGCN(391.98,IEN,0)),"^",1)
- +3 SET VALMBCK=""
- +4 DO FULL^VALM1
- +5 DO START^VAFCPDAT
- +6 ;D PAUSE^VALM1
- +7 SET VALMBCK="R"
- +8 QUIT
- +9 ;
- CENTER(STRG) ;
- +1 ;
- +2 NEW LEN,FIL,FIL1
- +3 SET LEN=80-$LENGTH(STRG)
- +4 SET FIL=LEN/2
- +5 SET $PIECE(FIL1," ",FIL)=""
- +6 QUIT FIL1_STRG
- +7 ;
- PDRPRG ;Purge PDRs ;**477
- +1 LOCK +^DGCN(391.98,"VAFC PDR PURGE"):0
- IF '$TEST
- WRITE $CHAR(7),!!,"The Purge Patient Data Reviews process is currently running."
- QUIT
- +2 LOCK -^DGCN(391.98,"VAFC PDR PURGE")
- +3 NEW TDATE,MAXDT,PDATE,X1,X2,X,Y
- +4 SET NDATE=""
- +5 DO NOW^%DTC
- SET TDATE=X
- +6 SET X1=TDATE
- SET X2=-30
- DO C^%DTC
- +7 SET (Y,MAXDT)=X
- DO DD^%DT
- SET PDATE=Y
- +8 SET DIR("?")="Enter a date at least 30 days in the past."
- +9 SET DIR("A")="Purge all Patient Data Reviews prior to "
- +10 SET DIR("B")=PDATE
- SET DIR(0)="DAO^:"_MAXDT_":EPX"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +11 SET NDATE=Y
- +12 SET DIR(0)="YA"
- SET DIR("B")="NO"
- +13 SET DIR("A")="Are you sure you want to purge Patient Data Reviews? "
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +14 if Y=0
- QUIT
- +15 ;
- +16 NEW ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTREQ
- +17 SET ZTRTN="QPRG^VAFCEHLM"
- SET ZTDESC="PURGE PATIENT DATA REVIEWS OVER 30 DAYS OLD OR X DAYS OLD AS SPECIFIED BY USER."
- +18 DO NOW^%DTC
- +19 SET ZTIO=""
- SET ZTDTH=%
- +20 IF $DATA(DUZ)
- SET ZTSAVE("DUZ")=DUZ
- SET ZTSAVE("NDATE")=NDATE
- +21 DO ^%ZTLOAD
- +22 WRITE !!?15,"Patient Data Review Purge Queued, Task #"_ZTSK
- +23 DO HOME^%ZIS
- KILL IO("Q")
- +24 QUIT
- QPRG ;
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 LOCK +^DGCN(391.98,"VAFC PDR PURGE"):0
- IF '$TEST
- QUIT
- +3 NEW PDR,EVTDT,ERR
- SET PDR=0
- SET EVTDT=""
- +4 FOR
- SET EVTDT=$ORDER(^DGCN(391.98,"EVT",EVTDT))
- if EVTDT>NDATE
- QUIT
- Begin DoDot:1
- +5 FOR
- SET PDR=$ORDER(^DGCN(391.98,"EVT",EVTDT,PDR))
- if 'PDR
- QUIT
- Begin DoDot:2
- +6 SET ERR=$$DELEXCPT^VAFCEHU1(PDR)
- End DoDot:2
- End DoDot:1
- +7 LOCK -^DGCN(391.98,"VAFC PDR PURGE")
- +8 KILL NDATE
- +9 QUIT