VAFCEHU2 ;ALB/JLU,LTL-UTILITIES FOR 391.98 AND 391.99 AND LIST MAN ;10/10/02 15:55
;;5.3;Registration;**149,255,333,474,477,620**;Aug 13, 1993
SORTS(SRT,ARY) ;
;this tag will sort the exceptions in different formats depending on
;what the user has selected.
;
;INPUTS - SRT this variable contains what sort is requested from the
;list man patient review screen.
; Ex. SP sort by patient
; SS sort by site
; SO sort by oldest event
; SN sort by newest event
;ARY - the array the calling program wants the info returned in.
;
;OUTPUT
;a populated array that was passed in by the user. The array is in
;the structure xxx(#,0)=value
;
S VAR=SRT_"(ARY)"
D @VAR
Q
;
SP(ARY) ;sort by patient
N LP,LP1,CTR
S LP=""
S CTR=1
F S LP=$O(^DGCN(391.98,"C",LP)) Q:LP="" F LP1=0:0 S LP1=$O(^DGCN(391.98,"C",LP,LP1)) Q:LP1="" D BLD(LP1,ARY,.CTR)
Q
;
SS(ARY) ;sort by site
N LP,LP1,CTR
S LP=""
S CTR=1
F S LP=$O(^DGCN(391.98,"FRM",LP)) Q:LP="" F LP1=0:0 S LP1=$O(^DGCN(391.98,"FRM",LP,LP1)) Q:LP1="" D BLD(LP1,ARY,.CTR)
Q
;
SO(ARY) ;sort by oldest event
N LP,LP1,CTR
S LP=""
S CTR=1
F S LP=$O(^DGCN(391.98,"EVT",LP)) Q:LP="" F LP1=0:0 S LP1=$O(^DGCN(391.98,"EVT",LP,LP1)) Q:LP1="" D BLD(LP1,ARY,.CTR)
Q
;
SN(ARY) ;sort by newest event
N LP,LP1,CTR
S LP=999999999999
S CTR=1
F S LP=$O(^DGCN(391.98,"EVT",LP),-1) Q:LP="" F LP1=999999999999:0 S LP1=$O(^DGCN(391.98,"EVT",LP,LP1),-1) Q:LP1="" D BLD(LP1,ARY,.CTR)
Q
;
BLD(LP1,ARY,CTR) ;this is the actual building subroutine. the array that is
;return is var(#,0)=value starting at 1.
;
N DATA,STAT,PAT,XX
;getting the exception
S DATA=$G(^DGCN(391.98,LP1,0))
Q:DATA']""
;checking for the status
;Q:$P(DATA,U,4)']"" ;**333
I $P(DATA,U,4)']"" S XX=$$EDIT^VAFCEHU1(LP1,"RETIRED DATA") Q ;**333 retire
;getting the status node from 391.984
S STAT=$G(^DGCN(391.984,$P(DATA,U,4),0))
;if retired skip
I "RETIRED DATA"=$P(STAT,U,1) Q
;if rejected skip
I "DATA REJECTED"=$P(STAT,U,1) Q
;if merge complete
I "MERGE COMPLETE"=$P(STAT,U,1) Q
;get patient file zero node
S PAT=$G(^DPT($P(DATA,U,1),0))
;Q:PAT']"" ;**333
I $S(PAT']"":1,$$IFLOCAL^MPIF001(+$P(DATA,U,1)):1,$$IFVCCI^MPIF001(+$P(DATA,U,1))=-1:1,1:0) S XX=$$EDIT^VAFCEHU1(LP1,"RETIRED DATA") Q ;**333 retire if a local, you're not the cmor or no cmor
S @ARY@(CTR,0)=$P(PAT,U,1)_U_$P(PAT,U,9)_U_$P(PAT,U,3)_U_$P(STAT,U,2)_U_$P(DATA,U,3)_U_$G(^DGCN(391.98,LP1,"FRM"))
S @ARY@(CTR,"VAFC")=LP1
S CTR=CTR+1
Q
;
FORMAT(ARY,VALMCNT,VALMQUIT) ;this subroutines formats the array in ARY
;from file 391.98 for display by the list manager. It accepts the
;array name as its input in ARY.
;VALMCNT and VALMQUIT are passed by reference
;VALMCNT will be the total number of entries
;VALMQUIT tells list man to quit if something when wrong.
;
N CTR,STR,LP
S CTR=1
F LP=0:0 S LP=$O(@ARY@(LP)) Q:'LP S STR=$G(@ARY@(LP,0)) I STR]"" DO
.N X,DATE
.S X=$$SETSTR^VALM1(CTR,"",1,4)
.S X=$$SETSTR^VALM1($E($P(STR,U,1),1,23),X,5,23)
.S X=$$SETSTR^VALM1($P(STR,U,2),X,29,9)
.S DATE=$$IN2EXDT^VAFCMGU0($P(STR,U,3))
.S X=$$SETSTR^VALM1(DATE,X,40,10)
.S X=$$SETSTR^VALM1($P(STR,U,4),X,51,2)
.S DATE=$$IN2EXDT^VAFCMGU0($P(STR,U,5))
.S X=$$SETSTR^VALM1(DATE,X,55,10)
.S X=$$SETSTR^VALM1($P(STR,U,6),X,67,$L($P(STR,U,6)))
.S @ARY@(LP,0)=X
.S @ARY@("IDX",CTR,CTR)=""
.S CTR=CTR+1
.Q
S VALMCNT=CTR-1
I CTR=1 DO
.S @ARY@(1,0)=""
.S @ARY@(2,0)="There are no exceptions on file to review."
.S VALMCNT=2
.Q
Q
;
FRMDATA(IEN,ARY) ;
;This entry point will return all the data related to a given exception
;INPUTS
; IEN - The IEN of the exception to be extracted.
; ARY - The array that the user wishes the information returned in.
; This array can be either local or global.
; Ex. ^TMP("TEST",$J)
; If and array is not passed then a default global array will
; be used. ^TMP($J,"VAFC-MRG","DATA")
;OUTPUTS
; 1 if the look up and retreival were successful
; 0^description if they were not.
;
N ERR,LP,DATA
I '$D(IEN) S ERR="0^Parameter not defined." G FRMQ
I IEN']"" S ERR="0^Exception not defined." G FRMQ
I '$D(^DGCN(391.98,IEN,0)) S ERR="0^Exception not in file." G FRMQ
I '$D(^DGCN(391.99,"B",IEN)) S ERR="0^Data for exception not defined." G FRMQ
I '$D(ARY) S ARY="^TMP($J,""VAFC-MRG"",""DATA"")"
I ARY']"" S ARY="^TMP($J,""VAFC-MRG"",""DATA"")"
S LP=""
F S LP=$O(^DGCN(391.99,"B",IEN,LP)) Q:'LP DO
. S DATA=$G(^DGCN(391.99,LP,0))
. Q:'DATA
. I $P(DATA,U,2)=""!($P(DATA,U,3)="") Q ;**477
. I $S($P(DATA,U,3)=.211:1,$P(DATA,U,3)=.2403:1,1:0) D ;**477 standardize mmn and nok for old pdr entries
. . N DGNAME S DGNAME=$G(^DGCN(391.99,LP,"VAL")) I $S(DGNAME="":0,DGNAME["@":0,1:1) D
. . . I $P(DATA,U,3)=.211 D STDNAME^XLFNAME(.DGNAME,"P") S DGNAME=$$FORMAT^XLFNAME7(.DGNAME,3,35) I DGNAME="" Q
. . . I $P(DATA,U,3)=.2403 D STDNAME^XLFNAME(.DGNAME,"P") S DGNAME=$$FORMAT^XLFNAME7(.DGNAME,3,35,,2,,1) I DGNAME="" Q
. . . D UPD(LP,50,DGNAME)
. I $P(DATA,U,3)=.05,($G(^DGCN(391.99,LP,"VAL"))="N") D UPD(LP,50,"NEVER MARRIED"),UPD(LP,.06,"@") S $P(DATA,"^",6)="" ;**477 translate marital status from 'n' to 'never married' and remove unresolved flag
. ;
. S @ARY@($P(DATA,U,2),$P(DATA,U,3))=$G(^DGCN(391.99,LP,"VAL"))_U_$P(DATA,U,5)_U_$P(DATA,U,6)
. Q
I $D(@ARY)>9 S ERR=1
E S ERR="0^No elments found."
;
FRMQ Q ERR
;
REVFUL ;this entry point is to process the user selection from the summary
;screen of the exception handler.
;the variable VALMAR is expected. This contains the array that is
;being used as part of list manager
;
;variable collision during VAFCMG01 processing, changed ien to ienpdr ;**477
;
S VALM("ENTITY")="Patient"
D EN^VALM2(XQORNOD(0))
I '$D(VALMY) G FULQ
N LP,RES
F LP=0:0 S LP=$O(VALMY(LP)) Q:'LP DO Q:RES<-9
.N IENPDR,LCK,MSG,EXCPT,FRM,STR,STAT,EDT,ARY
.S RES=0
.S IENPDR=$O(@VALMAR@("IDX",LP,0))
.Q:'IENPDR
.S IENPDR=$G(@VALMAR@(IENPDR,"VAFC"))
.Q:'IENPDR
.S LCK=$$LOCK^VAFCEHU1(IENPDR)
.I 'LCK DO Q
..N PAT
..S PAT=$E(@VALMAR@(LP,0),4,27)
..D FULL^VALM1
..W $C(7)
..W !!,"The status for ",PAT," is ",$P(LCK,U,2)
..W !,"Review or merging of this data is not allowed at this time."
..D PAUSE^VALM1
..Q
.S EXCPT=$G(^DGCN(391.98,IENPDR,0))
.S FRM=$G(^DGCN(391.98,IENPDR,"FRM"))
.I 'EXCPT!(FRM']"") Q
.S ARY="^TMP($J,""VAFC-MRG"",""DATA"")"
.S STR=$$FRMDATA(IENPDR,ARY)
.Q:'STR
.S RES=$$EN^VAFCMG01($P(EXCPT,U,1),ARY,FRM,$P(EXCPT,U,3))
.S STAT=$S(RES>11:"DR",RES>9:"MC",RES<2:"DE",1:"AR")
.S EDT=$$EDIT^VAFCEHU1(IENPDR,STAT)
.I RES=10!(RES=11) D WHO(IENPDR,DUZ,"NOW")
.L -^DGCN(391.98,IENPDR) ;**255
.Q
D INIT2^VAFCEHLM
;
FULQ Q
;
WHO(IEN,WHO,WHEN) ;this entry point updates the exceptions as to who
;made this update and when.
;
S DIE="^DGCN(391.98,"
S DA=IEN
S DR="12////"_DUZ_";11///"_WHEN
D ^DIE
Q
;
RETPDR(DFN,STAIEN) ;retire site's PDRs 'awaiting review' for patient ;**474
;INPUT DFN - ien of the patient
; STAIEN - ien of the institution
;
N DAT,IEN,NAM,PDRIEN,STANAM,VAFCINST
I 'DFN!'STAIEN Q
D GETS^DIQ(4,STAIEN_",",".01;999.1*",,"VAFCINST") ;retrieve current name and name history
S NAM=$G(VAFCINST(4,STAIEN_",",.01)) I NAM'="" S STANAM(NAM)="" ;get current name
S IEN="" F S IEN=$O(VAFCINST(4.999,IEN)) Q:IEN="" S NAM=$G(VAFCINST(4.999,IEN,.02)) I NAM'="" S STANAM(NAM)="" ;get name history in case site name change
S NAM="" F S NAM=$O(STANAM(NAM)) Q:NAM="" D ;loop through array of names
. S DAT=0 F S DAT=$O(^DGCN(391.98,"AKY",DFN,NAM,DAT)) Q:DAT="" D ;loop through site's pdrs for patient
. . S PDRIEN="" F S PDRIEN=$O(^DGCN(391.98,"AKY",DFN,NAM,DAT,PDRIEN)) Q:'PDRIEN I $P($G(^DGCN(391.98,PDRIEN,0)),"^",4)=1 S XX=$$EDIT^VAFCEHU1(PDRIEN,"RETIRED DATA") ;retire pdr's awaiting review
Q
;
UPD(DA,FLD,VAL) ;update value ;**477
L +^DGCN(391.99,DA,0):10
S DIE="^DGCN(391.99,"
S DR=FLD_"///^S X=VAL"
D ^DIE K DIE,DR
L -^DGCN(391.99,DA,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCEHU2 8129 printed Apr 09, 2024@21:39:03 Page 2
VAFCEHU2 ;ALB/JLU,LTL-UTILITIES FOR 391.98 AND 391.99 AND LIST MAN ;10/10/02 15:55
+1 ;;5.3;Registration;**149,255,333,474,477,620**;Aug 13, 1993
SORTS(SRT,ARY) ;
+1 ;this tag will sort the exceptions in different formats depending on
+2 ;what the user has selected.
+3 ;
+4 ;INPUTS - SRT this variable contains what sort is requested from the
+5 ;list man patient review screen.
+6 ; Ex. SP sort by patient
+7 ; SS sort by site
+8 ; SO sort by oldest event
+9 ; SN sort by newest event
+10 ;ARY - the array the calling program wants the info returned in.
+11 ;
+12 ;OUTPUT
+13 ;a populated array that was passed in by the user. The array is in
+14 ;the structure xxx(#,0)=value
+15 ;
+16 SET VAR=SRT_"(ARY)"
+17 DO @VAR
+18 QUIT
+19 ;
SP(ARY) ;sort by patient
+1 NEW LP,LP1,CTR
+2 SET LP=""
+3 SET CTR=1
+4 FOR
SET LP=$ORDER(^DGCN(391.98,"C",LP))
if LP=""
QUIT
FOR LP1=0:0
SET LP1=$ORDER(^DGCN(391.98,"C",LP,LP1))
if LP1=""
QUIT
DO BLD(LP1,ARY,.CTR)
+5 QUIT
+6 ;
SS(ARY) ;sort by site
+1 NEW LP,LP1,CTR
+2 SET LP=""
+3 SET CTR=1
+4 FOR
SET LP=$ORDER(^DGCN(391.98,"FRM",LP))
if LP=""
QUIT
FOR LP1=0:0
SET LP1=$ORDER(^DGCN(391.98,"FRM",LP,LP1))
if LP1=""
QUIT
DO BLD(LP1,ARY,.CTR)
+5 QUIT
+6 ;
SO(ARY) ;sort by oldest event
+1 NEW LP,LP1,CTR
+2 SET LP=""
+3 SET CTR=1
+4 FOR
SET LP=$ORDER(^DGCN(391.98,"EVT",LP))
if LP=""
QUIT
FOR LP1=0:0
SET LP1=$ORDER(^DGCN(391.98,"EVT",LP,LP1))
if LP1=""
QUIT
DO BLD(LP1,ARY,.CTR)
+5 QUIT
+6 ;
SN(ARY) ;sort by newest event
+1 NEW LP,LP1,CTR
+2 SET LP=999999999999
+3 SET CTR=1
+4 FOR
SET LP=$ORDER(^DGCN(391.98,"EVT",LP),-1)
if LP=""
QUIT
FOR LP1=999999999999:0
SET LP1=$ORDER(^DGCN(391.98,"EVT",LP,LP1),-1)
if LP1=""
QUIT
DO BLD(LP1,ARY,.CTR)
+5 QUIT
+6 ;
BLD(LP1,ARY,CTR) ;this is the actual building subroutine. the array that is
+1 ;return is var(#,0)=value starting at 1.
+2 ;
+3 NEW DATA,STAT,PAT,XX
+4 ;getting the exception
+5 SET DATA=$GET(^DGCN(391.98,LP1,0))
+6 if DATA']""
QUIT
+7 ;checking for the status
+8 ;Q:$P(DATA,U,4)']"" ;**333
+9 ;**333 retire
IF $PIECE(DATA,U,4)']""
SET XX=$$EDIT^VAFCEHU1(LP1,"RETIRED DATA")
QUIT
+10 ;getting the status node from 391.984
+11 SET STAT=$GET(^DGCN(391.984,$PIECE(DATA,U,4),0))
+12 ;if retired skip
+13 IF "RETIRED DATA"=$PIECE(STAT,U,1)
QUIT
+14 ;if rejected skip
+15 IF "DATA REJECTED"=$PIECE(STAT,U,1)
QUIT
+16 ;if merge complete
+17 IF "MERGE COMPLETE"=$PIECE(STAT,U,1)
QUIT
+18 ;get patient file zero node
+19 SET PAT=$GET(^DPT($PIECE(DATA,U,1),0))
+20 ;Q:PAT']"" ;**333
+21 ;**333 retire if a local, you're not the cmor or no cmor
IF $SELECT(PAT']"":1,$$IFLOCAL^MPIF001(+$PIECE(DATA,U,1)):1,$$IFVCCI^MPIF001(+$PIECE(DATA,U,1))=-1:1,1:0)
SET XX=$$EDIT^VAFCEHU1(LP1,"RETIRED DATA")
QUIT
+22 SET @ARY@(CTR,0)=$PIECE(PAT,U,1)_U_$PIECE(PAT,U,9)_U_$PIECE(PAT,U,3)_U_$PIECE(STAT,U,2)_U_$PIECE(DATA,U,3)_U_$GET(^DGCN(391.98,LP1,"FRM"))
+23 SET @ARY@(CTR,"VAFC")=LP1
+24 SET CTR=CTR+1
+25 QUIT
+26 ;
FORMAT(ARY,VALMCNT,VALMQUIT) ;this subroutines formats the array in ARY
+1 ;from file 391.98 for display by the list manager. It accepts the
+2 ;array name as its input in ARY.
+3 ;VALMCNT and VALMQUIT are passed by reference
+4 ;VALMCNT will be the total number of entries
+5 ;VALMQUIT tells list man to quit if something when wrong.
+6 ;
+7 NEW CTR,STR,LP
+8 SET CTR=1
+9 FOR LP=0:0
SET LP=$ORDER(@ARY@(LP))
if 'LP
QUIT
SET STR=$GET(@ARY@(LP,0))
IF STR]""
Begin DoDot:1
+10 NEW X,DATE
+11 SET X=$$SETSTR^VALM1(CTR,"",1,4)
+12 SET X=$$SETSTR^VALM1($EXTRACT($PIECE(STR,U,1),1,23),X,5,23)
+13 SET X=$$SETSTR^VALM1($PIECE(STR,U,2),X,29,9)
+14 SET DATE=$$IN2EXDT^VAFCMGU0($PIECE(STR,U,3))
+15 SET X=$$SETSTR^VALM1(DATE,X,40,10)
+16 SET X=$$SETSTR^VALM1($PIECE(STR,U,4),X,51,2)
+17 SET DATE=$$IN2EXDT^VAFCMGU0($PIECE(STR,U,5))
+18 SET X=$$SETSTR^VALM1(DATE,X,55,10)
+19 SET X=$$SETSTR^VALM1($PIECE(STR,U,6),X,67,$LENGTH($PIECE(STR,U,6)))
+20 SET @ARY@(LP,0)=X
+21 SET @ARY@("IDX",CTR,CTR)=""
+22 SET CTR=CTR+1
+23 QUIT
End DoDot:1
+24 SET VALMCNT=CTR-1
+25 IF CTR=1
Begin DoDot:1
+26 SET @ARY@(1,0)=""
+27 SET @ARY@(2,0)="There are no exceptions on file to review."
+28 SET VALMCNT=2
+29 QUIT
End DoDot:1
+30 QUIT
+31 ;
FRMDATA(IEN,ARY) ;
+1 ;This entry point will return all the data related to a given exception
+2 ;INPUTS
+3 ; IEN - The IEN of the exception to be extracted.
+4 ; ARY - The array that the user wishes the information returned in.
+5 ; This array can be either local or global.
+6 ; Ex. ^TMP("TEST",$J)
+7 ; If and array is not passed then a default global array will
+8 ; be used. ^TMP($J,"VAFC-MRG","DATA")
+9 ;OUTPUTS
+10 ; 1 if the look up and retreival were successful
+11 ; 0^description if they were not.
+12 ;
+13 NEW ERR,LP,DATA
+14 IF '$DATA(IEN)
SET ERR="0^Parameter not defined."
GOTO FRMQ
+15 IF IEN']""
SET ERR="0^Exception not defined."
GOTO FRMQ
+16 IF '$DATA(^DGCN(391.98,IEN,0))
SET ERR="0^Exception not in file."
GOTO FRMQ
+17 IF '$DATA(^DGCN(391.99,"B",IEN))
SET ERR="0^Data for exception not defined."
GOTO FRMQ
+18 IF '$DATA(ARY)
SET ARY="^TMP($J,""VAFC-MRG"",""DATA"")"
+19 IF ARY']""
SET ARY="^TMP($J,""VAFC-MRG"",""DATA"")"
+20 SET LP=""
+21 FOR
SET LP=$ORDER(^DGCN(391.99,"B",IEN,LP))
if 'LP
QUIT
Begin DoDot:1
+22 SET DATA=$GET(^DGCN(391.99,LP,0))
+23 if 'DATA
QUIT
+24 ;**477
IF $PIECE(DATA,U,2)=""!($PIECE(DATA,U,3)="")
QUIT
+25 ;**477 standardize mmn and nok for old pdr entries
IF $SELECT($PIECE(DATA,U,3)=.211:1,$PIECE(DATA,U,3)=.2403:1,1:0)
Begin DoDot:2
+26 NEW DGNAME
SET DGNAME=$GET(^DGCN(391.99,LP,"VAL"))
IF $SELECT(DGNAME="":0,DGNAME["@":0,1:1)
Begin DoDot:3
+27 IF $PIECE(DATA,U,3)=.211
DO STDNAME^XLFNAME(.DGNAME,"P")
SET DGNAME=$$FORMAT^XLFNAME7(.DGNAME,3,35)
IF DGNAME=""
QUIT
+28 IF $PIECE(DATA,U,3)=.2403
DO STDNAME^XLFNAME(.DGNAME,"P")
SET DGNAME=$$FORMAT^XLFNAME7(.DGNAME,3,35,,2,,1)
IF DGNAME=""
QUIT
+29 DO UPD(LP,50,DGNAME)
End DoDot:3
End DoDot:2
+30 ;**477 translate marital status from 'n' to 'never married' and remove unresolved flag
IF $PIECE(DATA,U,3)=.05
IF ($GET(^DGCN(391.99,LP,"VAL"))="N")
DO UPD(LP,50,"NEVER MARRIED")
DO UPD(LP,.06,"@")
SET $PIECE(DATA,"^",6)=""
+31 ;
+32 SET @ARY@($PIECE(DATA,U,2),$PIECE(DATA,U,3))=$GET(^DGCN(391.99,LP,"VAL"))_U_$PIECE(DATA,U,5)_U_$PIECE(DATA,U,6)
+33 QUIT
End DoDot:1
+34 IF $DATA(@ARY)>9
SET ERR=1
+35 IF '$TEST
SET ERR="0^No elments found."
+36 ;
FRMQ QUIT ERR
+1 ;
REVFUL ;this entry point is to process the user selection from the summary
+1 ;screen of the exception handler.
+2 ;the variable VALMAR is expected. This contains the array that is
+3 ;being used as part of list manager
+4 ;
+5 ;variable collision during VAFCMG01 processing, changed ien to ienpdr ;**477
+6 ;
+7 SET VALM("ENTITY")="Patient"
+8 DO EN^VALM2(XQORNOD(0))
+9 IF '$DATA(VALMY)
GOTO FULQ
+10 NEW LP,RES
+11 FOR LP=0:0
SET LP=$ORDER(VALMY(LP))
if 'LP
QUIT
Begin DoDot:1
+12 NEW IENPDR,LCK,MSG,EXCPT,FRM,STR,STAT,EDT,ARY
+13 SET RES=0
+14 SET IENPDR=$ORDER(@VALMAR@("IDX",LP,0))
+15 if 'IENPDR
QUIT
+16 SET IENPDR=$GET(@VALMAR@(IENPDR,"VAFC"))
+17 if 'IENPDR
QUIT
+18 SET LCK=$$LOCK^VAFCEHU1(IENPDR)
+19 IF 'LCK
Begin DoDot:2
+20 NEW PAT
+21 SET PAT=$EXTRACT(@VALMAR@(LP,0),4,27)
+22 DO FULL^VALM1
+23 WRITE $CHAR(7)
+24 WRITE !!,"The status for ",PAT," is ",$PIECE(LCK,U,2)
+25 WRITE !,"Review or merging of this data is not allowed at this time."
+26 DO PAUSE^VALM1
+27 QUIT
End DoDot:2
QUIT
+28 SET EXCPT=$GET(^DGCN(391.98,IENPDR,0))
+29 SET FRM=$GET(^DGCN(391.98,IENPDR,"FRM"))
+30 IF 'EXCPT!(FRM']"")
QUIT
+31 SET ARY="^TMP($J,""VAFC-MRG"",""DATA"")"
+32 SET STR=$$FRMDATA(IENPDR,ARY)
+33 if 'STR
QUIT
+34 SET RES=$$EN^VAFCMG01($PIECE(EXCPT,U,1),ARY,FRM,$PIECE(EXCPT,U,3))
+35 SET STAT=$SELECT(RES>11:"DR",RES>9:"MC",RES<2:"DE",1:"AR")
+36 SET EDT=$$EDIT^VAFCEHU1(IENPDR,STAT)
+37 IF RES=10!(RES=11)
DO WHO(IENPDR,DUZ,"NOW")
+38 ;**255
LOCK -^DGCN(391.98,IENPDR)
+39 QUIT
End DoDot:1
if RES<-9
QUIT
+40 DO INIT2^VAFCEHLM
+41 ;
FULQ QUIT
+1 ;
WHO(IEN,WHO,WHEN) ;this entry point updates the exceptions as to who
+1 ;made this update and when.
+2 ;
+3 SET DIE="^DGCN(391.98,"
+4 SET DA=IEN
+5 SET DR="12////"_DUZ_";11///"_WHEN
+6 DO ^DIE
+7 QUIT
+8 ;
RETPDR(DFN,STAIEN) ;retire site's PDRs 'awaiting review' for patient ;**474
+1 ;INPUT DFN - ien of the patient
+2 ; STAIEN - ien of the institution
+3 ;
+4 NEW DAT,IEN,NAM,PDRIEN,STANAM,VAFCINST
+5 IF 'DFN!'STAIEN
QUIT
+6 ;retrieve current name and name history
DO GETS^DIQ(4,STAIEN_",",".01;999.1*",,"VAFCINST")
+7 ;get current name
SET NAM=$GET(VAFCINST(4,STAIEN_",",.01))
IF NAM'=""
SET STANAM(NAM)=""
+8 ;get name history in case site name change
SET IEN=""
FOR
SET IEN=$ORDER(VAFCINST(4.999,IEN))
if IEN=""
QUIT
SET NAM=$GET(VAFCINST(4.999,IEN,.02))
IF NAM'=""
SET STANAM(NAM)=""
+9 ;loop through array of names
SET NAM=""
FOR
SET NAM=$ORDER(STANAM(NAM))
if NAM=""
QUIT
Begin DoDot:1
+10 ;loop through site's pdrs for patient
SET DAT=0
FOR
SET DAT=$ORDER(^DGCN(391.98,"AKY",DFN,NAM,DAT))
if DAT=""
QUIT
Begin DoDot:2
+11 ;retire pdr's awaiting review
SET PDRIEN=""
FOR
SET PDRIEN=$ORDER(^DGCN(391.98,"AKY",DFN,NAM,DAT,PDRIEN))
if 'PDRIEN
QUIT
IF $PIECE($GET(^DGCN(391.98,PDRIEN,0)),"^",4)=1
SET XX=$$EDIT^VAFCEHU1(PDRIEN,"RETIRED DATA")
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
UPD(DA,FLD,VAL) ;update value ;**477
+1 LOCK +^DGCN(391.99,DA,0):10
+2 SET DIE="^DGCN(391.99,"
+3 SET DR=FLD_"///^S X=VAL"
+4 DO ^DIE
KILL DIE,DR
+5 LOCK -^DGCN(391.99,DA,0)
+6 QUIT
