DG53426 ;ALB/AEG - DG*5.3*426 POST-INSTALLATION ;2-13-02
;;5.3;Registration;**426**;2-13-02
;
; The cleanup consists of 2 issues, they are as follows:
; 1. The patient file will be searched for patients that are not
; expired and have a means test status of required. If the tests
; are after 10/5/99, all of the patient's primary tests on record
; will be evaluated to determine if they would have met the
; criteria outlined in patch DG*5.3*326 had the functionality been
; in place at the time the REQUIRED status test was "stubbed" in
; the system. If this is found to be the case, the 'REQUIRED'
; tests will be purged from the system and the veteran will revert
; to the Category C, Agreed to Pay status.
; 2. The next issue to be evaluated during the search is those
; those patients who declined to provide income information but
; did Agree to Pay the deductible if they have a 'REQUIRED' status
; test on file. If they meet these criteria, regardless of the
; 10/5/99 restriction from #1, the 'REQUIRED' status tests will be
; purged from the system and the veteran will revert to the
; the previous Category C, Agreed to Pay status. A
; change of functionality will be required in order to preclude
; system from re-stubbing 'REQUIRED' status records.
;
EN ; MAIN ENTRY POINT
D INIT
Q
INIT ; Initialize tracking globals and associated checkpoints.
K ^TMP($J),^XTMP("DG-DFN"),^XTMP("DG-REQIEN")
N %,I,X,X1,X2
; Create Checkpoints
I $D(XPDNM) D
.I $$VERCP^XPDUTL("DFN")'>0 D
..S %=$$NEWCP^XPDUTL("DFN","",0)
.I $$VERCP^XPDUTL("REQIEN")'>0 D
..S %=$$NEWCP^XPDUTL("REQIEN","",0)
;
; init tracking globals
F I="DFN","REQIEN" D
.I $D(^XTMP("DG-"_I)) Q
.S X1=DT,X2=30 D C^%DTC
.S ^XTMP("DG-"_I,0)=X_U_$$DT^XLFDT_"^DG*5.3*426 POST INSTALL "
.S ^XTMP("DG-"_I,0)=^XTMP("DG-"_I,0)_$S(I="DFN":"Records Matching Search Criteria",I="REQIEN":"Required status tests purged",1:"errors")
I '$D(XPDNM) S (^XTMP("DG-DFN",1),^XTMP("DG-REQIEN",1))=0
;
; Check status and if root checkpoint has not completed start the
; cleanup.
I $D(XPDNM) S %=$$VERCP^XPDUTL("DFN") D
.I '$D(^XTMP("DG-DFN",1)) S ^XTMP("DG-DFN",1)=0
.I '$D(^XTMP("DG-REQIEN",1)) S ^XTMP("DG-REQIEN",1)=0
I $G(%)="" S %=0
I %=0 D EN1
Q
EN1 ; control the logic from this point.
D PSI
I '$D(^TMP($J,"MTD")) D BMES^XPDUTL("No data found requiring cleanup. Installation completed on"),MES^XPDUTL($$FMTE^XLFDT($$NOW^XLFDT)) Q
D PSII,CAT1A,CAT1B
D CAT2,CAT3,CAT4
Q
PSI ; MAIN SEARCH ENGINE
D BMES^XPDUTL("POST INSTALLATION PROCESSING")
D MES^XPDUTL("----------------------------")
D BMES^XPDUTL("Phase I - Search engine started on "_$$FMTE^XLFDT($$NOW^XLFDT))
D BMES^XPDUTL("Each '.' represents 200 records reviewed ...")
N DFN,MTIEN,DGMTDT,DGCNT,DGDOA
S (DFN,MTIEN,DGMTDT)=""
S DFN=0 F DGCNT=1:1 S DFN=$O(^DPT(DFN)) Q:'+DFN D
.I '$D(ZTQUEUED) W:'(DGCNT#200) "."
.S DGDOA=$P($G(^DPT(DFN,.35)),U)
.; Don't look at records of deceased patients.
.D:'+DGDOA
..N DGMTSTAT,DGMTLST
..S DGMTLST=$$LST^DGMTU(DFN,"",1),DGMTSTAT=$P($G(DGMTLST),U,4)
..; Only look at those patients whose latest primary test is in
..; a required status.
..I $G(DGMTSTAT)="R" D
...; Check Last valid test to make sure it is not Cat A or NLR
...N DGMTLVT,DGMTLVTS
...S DGMTLVT=$$LVMT^DGMTU(DFN),DGMTLVTS=$P($G(DGMTLVT),U,4)
...Q:((DGMTLVTS="N")!(DGMTLVTS="A"))
...; call API to setup a tmp global of a given patient's primary tests.
...; only if the test is Cat C or Pending Adj.
...D MTDA^DG53426U(DFN)
...Q
..Q
.Q
D BMES^XPDUTL("Phase I search completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
Q
PSII ; Phase II - Process data from Phase I search. Parse the data
; according to which group it belongs to, the groups are:
;
; 1. Cat C or Pend. Adj./Agreed to Pay/Income info provided/
; after 10/5/99
; 2. Cat C or Pend. Adj./ Declined to provide income info but did
; agree to pay deductible.
; 3. Cat C or Pending Adj / Declined to provide income info & did
; NOT provide income info. (Ineligible)
; 4. Cat C or Pending adj. / Provided income info but did NOT
; AGREE to pay deductible.
I $D(^TMP($J,"MTD")) D
.D BMES^XPDUTL("Phase II - Parsing data ...")
.N DFN,DGCNT,DGMTI,CAT
.S (DFN,DGMTI)=""
.F DGCNT=1:1 S DFN=$O(^TMP($J,"MTD",DFN)) Q:'DFN D
..I '$D(ZTQUEUED) W:'(DGCNT#200) "."
..S DGMTI=+$G(^TMP($J,"MTD",DFN)),CAT=$$AGTP^DG53426U(DGMTI)
..S ^TMP($J,"CAT "_CAT,DFN)=$G(^TMP($J,"MTD",DFN))
..S ^XTMP("DG-DFN",1)=$G(^XTMP("DG-DFN",1))+1
..I $D(XPDNM) S %=$$UPCP^XPDUTL("DFN",+DFN)
..K ^TMP($J,"MTD",DFN)
..Q
.D BMES^XPDUTL("Phase II completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
Q
CAT1A ; This tag will process those veterans who are in Category 1
; - Subcategory 1a - Vets who are in a REQUIRED status but have
; a previous test after 10/5/99 of Cat C or
; pending Adjudication & have agreed to Pay.
; REQUIRED test will be purged (Event driver is
; invoked).
; - Subcategory 1b - Vets who are in a REQUIRED status but have
; a previous test before 10/6/99 or Cat C or
; Pending Adjudication & have agreed to pay.
; (No action taken on these folks other than to
; report them to site for further action -- remain
; in a REQUIRED status.)
D BMES^XPDUTL("Phase III processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
I '$D(^TMP($J,"CAT 1a")) D
.D CAT1A^DG53426M
.D BMES^XPDUTL("Phase III processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
I $D(^TMP($J,"CAT 1a")) D
.N DFN,DGCDAT,DGMTDT,IEN
.S DFN="" F S DFN=$O(^TMP($J,"CAT 1a",DFN)) Q:'DFN D
..S DGCDAT=$P($P($G(^TMP($J,"CAT 1a",DFN)),"~~",2),U,1)
..S DGMTDT="" F S DGMTDT=$O(^DGMT(408.31,"AD",1,DFN,DGMTDT)) Q:'DGMTDT I DGMTDT>DGCDAT D
...S IEN="" F S IEN=$O(^DGMT(408.31,"AD",1,DFN,DGMTDT,IEN)) Q:'IEN D
....I $G(IEN),$P($G(^DGMT(408.31,IEN,0)),U,3)=1 D
.....S ^TMP("P-REQ",$J,DFN_"~~"_IEN)=$G(^DGMT(408.31,IEN,0))
.....I $$EN^DG53426D(IEN)
.....Q
....Q
...Q
..Q
.Q
I $D(^TMP("P-REQ",$J)) D CAT1AP^DG53426M,BMES^XPDUTL("Phase III processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
Q
;
CAT1B ; Process Cat 1b tests - See DG53426U for info on classification.
D BMES^XPDUTL("Phase IV processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
I '$D(^TMP($J,"CAT 1b")) D
.D CAT1B^DG53426M
.D BMES^XPDUTL("Phase IV processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
I $D(^TMP($J,"CAT 1b")) D
.D CAT1BR^DG53426M
.D BMES^XPDUTL("Phase IV completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
Q
CAT2 ; Process Cat 2 vets - See DG53426U for info on classification.
;
D BMES^XPDUTL("Phase V processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
I '$D(^TMP($J,"CAT 2")) D
.D NOCAT2^DG53426M
.D BMES^XPDUTL("Phase V processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
I $D(^TMP($J,"CAT 2")) D
.N DFN,DGCDAT,DGMTDT,IEN
.S DFN="" F S DFN=$O(^TMP($J,"CAT 2",DFN)) Q:'DFN D
..S DGCDAT=$P($P($G(^TMP($J,"CAT 2",DFN)),"~~",2),U,1)
..S DGMTDT="" F S DGMTDT=$O(^DGMT(408.31,"AD",1,DFN,DGMTDT)) Q:'DGMTDT I DGMTDT>DGCDAT D
...S IEN="" F S IEN=$O(^DGMT(408.31,"AD",1,DFN,DGMTDT,IEN)) Q:'IEN D
....I $D(IEN),$P($G(^DGMT(408.31,IEN,0)),U,3)=1 D
.....S ^TMP("P-REQ",$J,DFN_"~~"_IEN)=$G(^DGMT(408.31,IEN,0))
.....I $$EN^DG53426D(IEN)
.....Q
....Q
...Q
..Q
.Q
I $D(^TMP("P-REQ",$J)) D CAT2P^DG53426N,BMES^XPDUTL("Phase V processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
Q
CAT3 ; Process Cat 3 vets - See DG53426U for info on classification.
;
D BMES^XPDUTL("Phase VI processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
I '$D(^TMP($J,"CAT 3")) D
.D NOCAT3^DG53426N
.D BMES^XPDUTL("Phase VI processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
I $D(^TMP($J,"CAT 3")) D
.D CAT3^DG53426N
.D BMES^XPDUTL("Phase VI processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
Q
CAT4 ; Process Cat 4 vets - See DG53426U for info on classification.
;
D BMES^XPDUTL("Phase VII processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
I '$D(^TMP($J,"CAT 4")) D
.D NOCAT4^DG53426N
.D BMES^XPDUTL("Phase VII processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
I $D(^TMP($J,"CAT 4")) D
.D CAT4^DG53426N
.D BMES^XPDUTL("Phase VII processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53426 8581 printed Dec 13, 2024@02:37:25 Page 2
DG53426 ;ALB/AEG - DG*5.3*426 POST-INSTALLATION ;2-13-02
+1 ;;5.3;Registration;**426**;2-13-02
+2 ;
+3 ; The cleanup consists of 2 issues, they are as follows:
+4 ; 1. The patient file will be searched for patients that are not
+5 ; expired and have a means test status of required. If the tests
+6 ; are after 10/5/99, all of the patient's primary tests on record
+7 ; will be evaluated to determine if they would have met the
+8 ; criteria outlined in patch DG*5.3*326 had the functionality been
+9 ; in place at the time the REQUIRED status test was "stubbed" in
+10 ; the system. If this is found to be the case, the 'REQUIRED'
+11 ; tests will be purged from the system and the veteran will revert
+12 ; to the Category C, Agreed to Pay status.
+13 ; 2. The next issue to be evaluated during the search is those
+14 ; those patients who declined to provide income information but
+15 ; did Agree to Pay the deductible if they have a 'REQUIRED' status
+16 ; test on file. If they meet these criteria, regardless of the
+17 ; 10/5/99 restriction from #1, the 'REQUIRED' status tests will be
+18 ; purged from the system and the veteran will revert to the
+19 ; the previous Category C, Agreed to Pay status. A
+20 ; change of functionality will be required in order to preclude
+21 ; system from re-stubbing 'REQUIRED' status records.
+22 ;
EN ; MAIN ENTRY POINT
+1 DO INIT
+2 QUIT
INIT ; Initialize tracking globals and associated checkpoints.
+1 KILL ^TMP($JOB),^XTMP("DG-DFN"),^XTMP("DG-REQIEN")
+2 NEW %,I,X,X1,X2
+3 ; Create Checkpoints
+4 IF $DATA(XPDNM)
Begin DoDot:1
+5 IF $$VERCP^XPDUTL("DFN")'>0
Begin DoDot:2
+6 SET %=$$NEWCP^XPDUTL("DFN","",0)
End DoDot:2
+7 IF $$VERCP^XPDUTL("REQIEN")'>0
Begin DoDot:2
+8 SET %=$$NEWCP^XPDUTL("REQIEN","",0)
End DoDot:2
End DoDot:1
+9 ;
+10 ; init tracking globals
+11 FOR I="DFN","REQIEN"
Begin DoDot:1
+12 IF $DATA(^XTMP("DG-"_I))
QUIT
+13 SET X1=DT
SET X2=30
DO C^%DTC
+14 SET ^XTMP("DG-"_I,0)=X_U_$$DT^XLFDT_"^DG*5.3*426 POST INSTALL "
+15 SET ^XTMP("DG-"_I,0)=^XTMP("DG-"_I,0)_$SELECT(I="DFN":"Records Matching Search Criteria",I="REQIEN":"Required status tests purged",1:"errors")
End DoDot:1
+16 IF '$DATA(XPDNM)
SET (^XTMP("DG-DFN",1),^XTMP("DG-REQIEN",1))=0
+17 ;
+18 ; Check status and if root checkpoint has not completed start the
+19 ; cleanup.
+20 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DFN")
Begin DoDot:1
+21 IF '$DATA(^XTMP("DG-DFN",1))
SET ^XTMP("DG-DFN",1)=0
+22 IF '$DATA(^XTMP("DG-REQIEN",1))
SET ^XTMP("DG-REQIEN",1)=0
End DoDot:1
+23 IF $GET(%)=""
SET %=0
+24 IF %=0
DO EN1
+25 QUIT
EN1 ; control the logic from this point.
+1 DO PSI
+2 IF '$DATA(^TMP($JOB,"MTD"))
DO BMES^XPDUTL("No data found requiring cleanup. Installation completed on")
DO MES^XPDUTL($$FMTE^XLFDT($$NOW^XLFDT))
QUIT
+3 DO PSII
DO CAT1A
DO CAT1B
+4 DO CAT2
DO CAT3
DO CAT4
+5 QUIT
PSI ; MAIN SEARCH ENGINE
+1 DO BMES^XPDUTL("POST INSTALLATION PROCESSING")
+2 DO MES^XPDUTL("----------------------------")
+3 DO BMES^XPDUTL("Phase I - Search engine started on "_$$FMTE^XLFDT($$NOW^XLFDT))
+4 DO BMES^XPDUTL("Each '.' represents 200 records reviewed ...")
+5 NEW DFN,MTIEN,DGMTDT,DGCNT,DGDOA
+6 SET (DFN,MTIEN,DGMTDT)=""
+7 SET DFN=0
FOR DGCNT=1:1
SET DFN=$ORDER(^DPT(DFN))
if '+DFN
QUIT
Begin DoDot:1
+8 IF '$DATA(ZTQUEUED)
if '(DGCNT#200)
WRITE "."
+9 SET DGDOA=$PIECE($GET(^DPT(DFN,.35)),U)
+10 ; Don't look at records of deceased patients.
+11 if '+DGDOA
Begin DoDot:2
+12 NEW DGMTSTAT,DGMTLST
+13 SET DGMTLST=$$LST^DGMTU(DFN,"",1)
SET DGMTSTAT=$PIECE($GET(DGMTLST),U,4)
+14 ; Only look at those patients whose latest primary test is in
+15 ; a required status.
+16 IF $GET(DGMTSTAT)="R"
Begin DoDot:3
+17 ; Check Last valid test to make sure it is not Cat A or NLR
+18 NEW DGMTLVT,DGMTLVTS
+19 SET DGMTLVT=$$LVMT^DGMTU(DFN)
SET DGMTLVTS=$PIECE($GET(DGMTLVT),U,4)
+20 if ((DGMTLVTS="N")!(DGMTLVTS="A"))
QUIT
+21 ; call API to setup a tmp global of a given patient's primary tests.
+22 ; only if the test is Cat C or Pending Adj.
+23 DO MTDA^DG53426U(DFN)
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 DO BMES^XPDUTL("Phase I search completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+28 QUIT
PSII ; Phase II - Process data from Phase I search. Parse the data
+1 ; according to which group it belongs to, the groups are:
+2 ;
+3 ; 1. Cat C or Pend. Adj./Agreed to Pay/Income info provided/
+4 ; after 10/5/99
+5 ; 2. Cat C or Pend. Adj./ Declined to provide income info but did
+6 ; agree to pay deductible.
+7 ; 3. Cat C or Pending Adj / Declined to provide income info & did
+8 ; NOT provide income info. (Ineligible)
+9 ; 4. Cat C or Pending adj. / Provided income info but did NOT
+10 ; AGREE to pay deductible.
+11 IF $DATA(^TMP($JOB,"MTD"))
Begin DoDot:1
+12 DO BMES^XPDUTL("Phase II - Parsing data ...")
+13 NEW DFN,DGCNT,DGMTI,CAT
+14 SET (DFN,DGMTI)=""
+15 FOR DGCNT=1:1
SET DFN=$ORDER(^TMP($JOB,"MTD",DFN))
if 'DFN
QUIT
Begin DoDot:2
+16 IF '$DATA(ZTQUEUED)
if '(DGCNT#200)
WRITE "."
+17 SET DGMTI=+$GET(^TMP($JOB,"MTD",DFN))
SET CAT=$$AGTP^DG53426U(DGMTI)
+18 SET ^TMP($JOB,"CAT "_CAT,DFN)=$GET(^TMP($JOB,"MTD",DFN))
+19 SET ^XTMP("DG-DFN",1)=$GET(^XTMP("DG-DFN",1))+1
+20 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DFN",+DFN)
+21 KILL ^TMP($JOB,"MTD",DFN)
+22 QUIT
End DoDot:2
+23 DO BMES^XPDUTL("Phase II completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+24 QUIT
End DoDot:1
+25 QUIT
CAT1A ; This tag will process those veterans who are in Category 1
+1 ; - Subcategory 1a - Vets who are in a REQUIRED status but have
+2 ; a previous test after 10/5/99 of Cat C or
+3 ; pending Adjudication & have agreed to Pay.
+4 ; REQUIRED test will be purged (Event driver is
+5 ; invoked).
+6 ; - Subcategory 1b - Vets who are in a REQUIRED status but have
+7 ; a previous test before 10/6/99 or Cat C or
+8 ; Pending Adjudication & have agreed to pay.
+9 ; (No action taken on these folks other than to
+10 ; report them to site for further action -- remain
+11 ; in a REQUIRED status.)
+12 DO BMES^XPDUTL("Phase III processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
+13 IF '$DATA(^TMP($JOB,"CAT 1a"))
Begin DoDot:1
+14 DO CAT1A^DG53426M
+15 DO BMES^XPDUTL("Phase III processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+16 QUIT
End DoDot:1
+17 IF $DATA(^TMP($JOB,"CAT 1a"))
Begin DoDot:1
+18 NEW DFN,DGCDAT,DGMTDT,IEN
+19 SET DFN=""
FOR
SET DFN=$ORDER(^TMP($JOB,"CAT 1a",DFN))
if 'DFN
QUIT
Begin DoDot:2
+20 SET DGCDAT=$PIECE($PIECE($GET(^TMP($JOB,"CAT 1a",DFN)),"~~",2),U,1)
+21 SET DGMTDT=""
FOR
SET DGMTDT=$ORDER(^DGMT(408.31,"AD",1,DFN,DGMTDT))
if 'DGMTDT
QUIT
IF DGMTDT>DGCDAT
Begin DoDot:3
+22 SET IEN=""
FOR
SET IEN=$ORDER(^DGMT(408.31,"AD",1,DFN,DGMTDT,IEN))
if 'IEN
QUIT
Begin DoDot:4
+23 IF $GET(IEN)
IF $PIECE($GET(^DGMT(408.31,IEN,0)),U,3)=1
Begin DoDot:5
+24 SET ^TMP("P-REQ",$JOB,DFN_"~~"_IEN)=$GET(^DGMT(408.31,IEN,0))
+25 IF $$EN^DG53426D(IEN)
+26 QUIT
End DoDot:5
+27 QUIT
End DoDot:4
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 IF $DATA(^TMP("P-REQ",$JOB))
DO CAT1AP^DG53426M
DO BMES^XPDUTL("Phase III processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+32 QUIT
+33 ;
CAT1B ; Process Cat 1b tests - See DG53426U for info on classification.
+1 DO BMES^XPDUTL("Phase IV processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
+2 IF '$DATA(^TMP($JOB,"CAT 1b"))
Begin DoDot:1
+3 DO CAT1B^DG53426M
+4 DO BMES^XPDUTL("Phase IV processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+5 QUIT
End DoDot:1
+6 IF $DATA(^TMP($JOB,"CAT 1b"))
Begin DoDot:1
+7 DO CAT1BR^DG53426M
+8 DO BMES^XPDUTL("Phase IV completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+9 QUIT
End DoDot:1
+10 QUIT
CAT2 ; Process Cat 2 vets - See DG53426U for info on classification.
+1 ;
+2 DO BMES^XPDUTL("Phase V processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
+3 IF '$DATA(^TMP($JOB,"CAT 2"))
Begin DoDot:1
+4 DO NOCAT2^DG53426M
+5 DO BMES^XPDUTL("Phase V processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+6 QUIT
End DoDot:1
+7 IF $DATA(^TMP($JOB,"CAT 2"))
Begin DoDot:1
+8 NEW DFN,DGCDAT,DGMTDT,IEN
+9 SET DFN=""
FOR
SET DFN=$ORDER(^TMP($JOB,"CAT 2",DFN))
if 'DFN
QUIT
Begin DoDot:2
+10 SET DGCDAT=$PIECE($PIECE($GET(^TMP($JOB,"CAT 2",DFN)),"~~",2),U,1)
+11 SET DGMTDT=""
FOR
SET DGMTDT=$ORDER(^DGMT(408.31,"AD",1,DFN,DGMTDT))
if 'DGMTDT
QUIT
IF DGMTDT>DGCDAT
Begin DoDot:3
+12 SET IEN=""
FOR
SET IEN=$ORDER(^DGMT(408.31,"AD",1,DFN,DGMTDT,IEN))
if 'IEN
QUIT
Begin DoDot:4
+13 IF $DATA(IEN)
IF $PIECE($GET(^DGMT(408.31,IEN,0)),U,3)=1
Begin DoDot:5
+14 SET ^TMP("P-REQ",$JOB,DFN_"~~"_IEN)=$GET(^DGMT(408.31,IEN,0))
+15 IF $$EN^DG53426D(IEN)
+16 QUIT
End DoDot:5
+17 QUIT
End DoDot:4
+18 QUIT
End DoDot:3
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 IF $DATA(^TMP("P-REQ",$JOB))
DO CAT2P^DG53426N
DO BMES^XPDUTL("Phase V processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+22 QUIT
CAT3 ; Process Cat 3 vets - See DG53426U for info on classification.
+1 ;
+2 DO BMES^XPDUTL("Phase VI processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
+3 IF '$DATA(^TMP($JOB,"CAT 3"))
Begin DoDot:1
+4 DO NOCAT3^DG53426N
+5 DO BMES^XPDUTL("Phase VI processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+6 QUIT
End DoDot:1
+7 IF $DATA(^TMP($JOB,"CAT 3"))
Begin DoDot:1
+8 DO CAT3^DG53426N
+9 DO BMES^XPDUTL("Phase VI processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+10 QUIT
End DoDot:1
+11 QUIT
CAT4 ; Process Cat 4 vets - See DG53426U for info on classification.
+1 ;
+2 DO BMES^XPDUTL("Phase VII processing began on "_$$FMTE^XLFDT($$NOW^XLFDT))
+3 IF '$DATA(^TMP($JOB,"CAT 4"))
Begin DoDot:1
+4 DO NOCAT4^DG53426N
+5 DO BMES^XPDUTL("Phase VII processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+6 QUIT
End DoDot:1
+7 IF $DATA(^TMP($JOB,"CAT 4"))
Begin DoDot:1
+8 DO CAT4^DG53426N
+9 DO BMES^XPDUTL("Phase VII processing completed on "_$$FMTE^XLFDT($$NOW^XLFDT))
+10 QUIT
End DoDot:1
+11 QUIT
