AGMP72P3 ; IHS/SD/KJH - AG*7.2*3 Post Install ;
;;7.2;IHS PATIENT REGISTRATION;**3**;JAN 07, 2011;Build 4
;
Q
POST ; Post Install Entry Point
D BMES^XPDUTL("Starting Post-Install")
D PAT
D HLO
D CNT
D BMES^XPDUTL("Post-Install is complete")
Q
;
PAT ;
N DFNIEN,CNT,CNT2,PICN,TFLIEN,TICN,DIE,DA,DR,DTOUT
D BMES^XPDUTL(" Updating ICNs in the VA Patient file")
; Loop through patients and update the ICN
S DFNIEN=0,CNT=0,CNT2=0
F S DFNIEN=$O(^DPT(DFNIEN)) Q:'DFNIEN D
. S CNT=CNT+1
. I CNT#10000=1 W "."
. ; Get the ICN from the VA PATIENT file
. S PICN=$$GET1^DIQ(2,DFNIEN_",",991.01,"E")
. ; Get the ICN from the Treating Facility List (TFL), if there is a record for the patient
. S TICN=""
. S TFLIEN=$O(^DGCN(391.91,"B",DFNIEN,""))
. I TFLIEN S TICN=$$GET1^DIQ(391.91,TFLIEN_",",9999999.02,"E")
. ; Quit if the ICNs are the same - no need to update
. I PICN=TICN Q
. K DIE,DA,DR
. S DIE="^DPT("
. S DA=DFNIEN
. I TICN="" S DR="991.01////@"
. E S DR="991.01////^S X=TICN"
. L +^DPT(DA):5 I '$T D BMES^XPDUTL(" Could not lock patient "_$P($G(^DPT(DA,0)),"^",1)_" ("_DA_"). ICN should be "_TICN) Q
. D ^DIE L -^DPT(DA) S CNT2=CNT2+1
. Q
D BMES^XPDUTL(" "_CNT2_" patients updated")
Q
;
HLO ;
N QUEUE,HL778IEN,MSG,CNT,CNT2
D BMES^XPDUTL(" Clearing Invalid Entries on the HLO queue")
S QUEUE="",CNT=0,CNT2=0
F S QUEUE=$O(^HLB("QUEUE","OUT",QUEUE)) Q:QUEUE="" D
. S HL778IEN=""
. F S HL778IEN=$O(^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN)) Q:'HL778IEN D
.. S CNT=CNT+1
.. I CNT#1000=1 W "."
.. S MSG=$G(^HLB(HL778IEN,0))
.. I MSG="" K ^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN) S CNT2=CNT2+1 Q
.. I MSG'["MPI RPMS" K ^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN) S CNT2=CNT2+1 Q
.. I $P(MSG,U,9),$P(MSG,U,20)="SU" K ^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN) S CNT2=CNT2+1 Q
D BMES^XPDUTL(" "_CNT2_" entries corrected")
Q
CNT ; Find latest message number that was used in each category and reset the message IEN counters.
N INTCP,INNOTCP,OUTTCP,OUTNOTCP,OUT
D BMES^XPDUTL(" Checking/resetting HLO message counters")
; Global ^HLA; File 777
;^HLC("FILE777","OUT") 0 thru 99999999999
S OUT=$O(^HLA(100000000000),-1)
S ^HLC("FILE777","OUT")=OUT
;^HLC("FILE777","IN","TCP") 100000000000 thru 199999999999
S INTCP=$O(^HLA(200000000000),-1)
I INTCP<100000000000 S INTCP=0
E S INTCP=INTCP#100000000000
S ^HLC("FILE777","IN","TCP")=INTCP
;^HLC("FILE777","IN","NOT TCP") 200000000000 thru 299999999999
S INNOTCP=$O(^HLA(300000000000),-1)
I INNOTCP<200000000000 S INNOTCP=0
E S INNOTCP=INNOTCP#200000000000
S ^HLC("FILE777","IN","NOT TCP")=INNOTCP
; Global HLB; File 778
;^HLC("FILE778","OUT","TCP") 0 thru 99999999999
S OUTTCP=$O(^HLB(100000000000),-1)
S ^HLC("FILE778","OUT","TCP")=OUTTCP
;^HLC("FILE778","OUT","NOT TCP") 100000000000 thru 199999999999
S OUTNOTCP=$O(^HLB(200000000000),-1)
I OUTNOTCP<100000000000 S OUTNOTCP=0
E S OUTTCP=OUTTCP#100000000000
S ^HLC("FILE778","OUT","NOT TCP")=OUTNOTCP
;^HLC("FILE778","IN","TCP") 200000000000 thru 299999999999
S INTCP=$O(^HLB(300000000000),-1)
I INTCP<200000000000 S INTCP=0
E S INTCP=INTCP#200000000000
S ^HLC("FILE778","IN","TCP")=INTCP
;^HLC("FILE778","IN","NOT TCP") 300000000000 thru 399999999999
S INNOTCP=$O(^HLB(400000000000),-1)
I INNOTCP<300000000000 S INNOTCP=0
E S INNOTCP=INNOTCP#300000000000
S ^HLC("FILE778","IN","NOT TCP")=INNOTCP
Q
AGMP72P3 ; IHS/SD/KJH - AG*7.2*3 Post Install ;
+1 ;;7.2;IHS PATIENT REGISTRATION;**3**;JAN 07, 2011;Build 4
+2 ;
+3 QUIT
POST ; Post Install Entry Point
+1 DO BMES^XPDUTL("Starting Post-Install")
+2 DO PAT
+3 DO HLO
+4 DO CNT
+5 DO BMES^XPDUTL("Post-Install is complete")
+6 QUIT
+7 ;
PAT ;
+1 NEW DFNIEN,CNT,CNT2,PICN,TFLIEN,TICN,DIE,DA,DR,DTOUT
+2 DO BMES^XPDUTL(" Updating ICNs in the VA Patient file")
+3 ; Loop through patients and update the ICN
+4 SET DFNIEN=0
SET CNT=0
SET CNT2=0
+5 FOR
SET DFNIEN=$ORDER(^DPT(DFNIEN))
IF 'DFNIEN
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 IF CNT#10000=1
WRITE "."
+8 ; Get the ICN from the VA PATIENT file
+9 SET PICN=$$GET1^DIQ(2,DFNIEN_",",991.01,"E")
+10 ; Get the ICN from the Treating Facility List (TFL), if there is a record for the patient
+11 SET TICN=""
+12 SET TFLIEN=$ORDER(^DGCN(391.91,"B",DFNIEN,""))
+13 IF TFLIEN
SET TICN=$$GET1^DIQ(391.91,TFLIEN_",",9999999.02,"E")
+14 ; Quit if the ICNs are the same - no need to update
+15 IF PICN=TICN
QUIT
+16 KILL DIE,DA,DR
+17 SET DIE="^DPT("
+18 SET DA=DFNIEN
+19 IF TICN=""
SET DR="991.01////@"
+20 IF '$TEST
SET DR="991.01////^S X=TICN"
+21 LOCK +^DPT(DA):5
IF '$TEST
DO BMES^XPDUTL(" Could not lock patient "_$PIECE($GET(^DPT(DA,0)),"^",1)_" ("_DA_"). ICN should be "_TICN)
QUIT
+22 DO ^DIE
LOCK -^DPT(DA)
SET CNT2=CNT2+1
+23 QUIT
End DoDot:1
+24 DO BMES^XPDUTL(" "_CNT2_" patients updated")
+25 QUIT
+26 ;
HLO ;
+1 NEW QUEUE,HL778IEN,MSG,CNT,CNT2
+2 DO BMES^XPDUTL(" Clearing Invalid Entries on the HLO queue")
+3 SET QUEUE=""
SET CNT=0
SET CNT2=0
+4 FOR
SET QUEUE=$ORDER(^HLB("QUEUE","OUT",QUEUE))
IF QUEUE=""
QUIT
Begin DoDot:1
+5 SET HL778IEN=""
+6 FOR
SET HL778IEN=$ORDER(^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN))
IF 'HL778IEN
QUIT
Begin DoDot:2
+7 SET CNT=CNT+1
+8 IF CNT#1000=1
WRITE "."
+9 SET MSG=$GET(^HLB(HL778IEN,0))
+10 IF MSG=""
KILL ^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN)
SET CNT2=CNT2+1
QUIT
+11 IF MSG'["MPI RPMS"
KILL ^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN)
SET CNT2=CNT2+1
QUIT
+12 IF $PIECE(MSG,U,9)
IF $PIECE(MSG,U,20)="SU"
KILL ^HLB("QUEUE","OUT",QUEUE,"MPI RPMS",HL778IEN)
SET CNT2=CNT2+1
QUIT
End DoDot:2
End DoDot:1
+13 DO BMES^XPDUTL(" "_CNT2_" entries corrected")
+14 QUIT
CNT ; Find latest message number that was used in each category and reset the message IEN counters.
+1 NEW INTCP,INNOTCP,OUTTCP,OUTNOTCP,OUT
+2 DO BMES^XPDUTL(" Checking/resetting HLO message counters")
+3 ; Global ^HLA; File 777
+4 ;^HLC("FILE777","OUT") 0 thru 99999999999
+5 SET OUT=$ORDER(^HLA(100000000000),-1)
+6 SET ^HLC("FILE777","OUT")=OUT
+7 ;^HLC("FILE777","IN","TCP") 100000000000 thru 199999999999
+8 SET INTCP=$ORDER(^HLA(200000000000),-1)
+9 IF INTCP<100000000000
SET INTCP=0
+10 IF '$TEST
SET INTCP=INTCP#100000000000
+11 SET ^HLC("FILE777","IN","TCP")=INTCP
+12 ;^HLC("FILE777","IN","NOT TCP") 200000000000 thru 299999999999
+13 SET INNOTCP=$ORDER(^HLA(300000000000),-1)
+14 IF INNOTCP<200000000000
SET INNOTCP=0
+15 IF '$TEST
SET INNOTCP=INNOTCP#200000000000
+16 SET ^HLC("FILE777","IN","NOT TCP")=INNOTCP
+17 ; Global HLB; File 778
+18 ;^HLC("FILE778","OUT","TCP") 0 thru 99999999999
+19 SET OUTTCP=$ORDER(^HLB(100000000000),-1)
+20 SET ^HLC("FILE778","OUT","TCP")=OUTTCP
+21 ;^HLC("FILE778","OUT","NOT TCP") 100000000000 thru 199999999999
+22 SET OUTNOTCP=$ORDER(^HLB(200000000000),-1)
+23 IF OUTNOTCP<100000000000
SET OUTNOTCP=0
+24 IF '$TEST
SET OUTTCP=OUTTCP#100000000000
+25 SET ^HLC("FILE778","OUT","NOT TCP")=OUTNOTCP
+26 ;^HLC("FILE778","IN","TCP") 200000000000 thru 299999999999
+27 SET INTCP=$ORDER(^HLB(300000000000),-1)
+28 IF INTCP<200000000000
SET INTCP=0
+29 IF '$TEST
SET INTCP=INTCP#200000000000
+30 SET ^HLC("FILE778","IN","TCP")=INTCP
+31 ;^HLC("FILE778","IN","NOT TCP") 300000000000 thru 399999999999
+32 SET INNOTCP=$ORDER(^HLB(400000000000),-1)
+33 IF INNOTCP<300000000000
SET INNOTCP=0
+34 IF '$TEST
SET INNOTCP=INNOTCP#300000000000
+35 SET ^HLC("FILE778","IN","NOT TCP")=INNOTCP
+36 QUIT
