BPMXFX2 ;IHS/OIT/NKD - CLEANUP UTILITY - SPLIT INTO MULTIPLE ROUTINES - 6/26/12 ;
;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
;
Q
WP ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX WORD PROCESSING FIELD ENTRIES
;
N BPMTO,BPMCNT,BPMCNT2,BPMCNT3,I,J,X,D1,XIEN,XFLD,XGLFR,XDFR,XGLTO,XGL0,XDTO,XCNT
N ABSPE,AMHPINTK,AUPNPAT,BATREG,BIP,BWP,PS,SCPT
;
S XIEN="FROM"
F S XIEN=$O(^TMP("BPM",$J,XIEN),-1) Q:+XIEN'=XIEN D
. N BPMFR,BPMTO,XIENS,ABSPE,AMHPINTK,AUPNPAT,BATREG,BIP,BWP,PS,SCPT
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,"")),XIENS=$G(^TMP("BPM",$J,XIEN,BPMFR,BPMTO)),BPMCNT=0
. D GETXWP
. ; ITERATE THROUGH WP FIELDS
. F I=1:1 S X=$P($T(WPFLDS+I),";;",2) Q:X["$$END" D
. . ; ITERATE THROUGH WP SUBSCRIPTS
. . F J=1:1 S XFLD=$P($P(X,";",3),"^",J) Q:$L(XFLD)<1 D
. . . S XGLFR=$P(X,";",2)_BPMFR_","_XFLD,XGL0="^"_$P(X,";",2),XGLTO=XGL0_$$LAST^BPMXFIX(BPMFR)_","_XFLD
. . . ; QUIT IF FROM PATIENT DID NOT HAVE DATA
. . . Q:'$D(@(XGLFR_")"))
. . . ; CONCAT WP ARRAYS INTO A STRING
. . . S XCNT=0,XDFR=""
. . . F S XCNT=$O(@(XGLFR_")")@(XCNT)) Q:'XCNT S XDFR=XDFR_" "_@(XGLFR_","_XCNT_",0)")
. . . S XCNT=0,XDTO=""
. . . F S XCNT=$O(@(XGLTO_")")@(XCNT)) Q:'XCNT S XDTO=XDTO_" "_@(XGLTO_","_XCNT_",0)")
. . . ; CHECK IF THE FROM WP FIELD WAS ALREADY MERGED
. . . Q:XDTO[XDFR
. . . S D1=+$P($G(@(XGLTO_",0)")),U,3)
. . . ;D RSLT^BPMXFIX($J("",2)_"Appending to: "_XGLTO)
. . . ; APPEND TO THE TO PATIENT
. . . S XCNT=0
. . . F S XCNT=$O(@(XGLFR_")")@(XCNT)) Q:'XCNT D
. . . . S D1=D1+1
. . . . S @(XGLTO_","_D1_",0)")=@(XGLFR_","_XCNT_",0)")
. . . . S $P(@(XGLTO_",0)"),U,3,5)=D1_U_D1_U_$$DT^XLFDT()
. . . S BPMCNT=BPMCNT+1
. I BPMCNT D HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2)),RSLT^BPMXFIX(" *** FROM Patient IEN: "_BPMFR_" Total Found: "_BPMCNT_" ***")
;
S BPMTO=0
F S BPMTO=$O(^TMP("BPM",$J,"TO",BPMTO)) Q:+BPMTO'=BPMTO D
. Q:$$LAST^BPMXFIX(BPMTO)'=BPMTO
. S (BPMCNT2,BPMCNT3)=0
. ; ITERATE THROUGH WP FIELDS
. F I=1:1 S X=$P($T(WPFLDS+I),";;",2) Q:X["$$END" D
. . ; ITERATE THROUGH WP SUBSCRIPTS
. . F J=1:1 S XFLD=$P($P(X,";",3),"^",J) Q:$L(XFLD)<1 D
. . . S XGL0="^"_$P(X,";",2),XGLTO=XGL0_BPMTO_","_XFLD
. . . Q:'$D(@(XGLTO_",0)"))
. . . ; CREATE ENTRY IN PARENT FILE IF IT DOESN'T EXIST
. . . I '$D(@(XGL0_BPMTO_",0)")) D Q
. . . . ;D RSLT^BPMXFIX($J("",2)_"Creating parent ("_$P(X,";",1)_") entry")
. . . . N ORIEN,FDA,ERR
. . . . S ORIEN(1)=BPMTO
. . . . S FDA($P(X,";",4),"+1,",.01)=BPMTO
. . . . D UPDATE^DIE(,"FDA","ORIEN","ERR")
. . . . I $D(ERR) D RSLT^BPMXFIX($J("",4)_"ADD FAILED!") Q
. . . . S BPMCNT2=BPMCNT2+1
. . . ; CORRECT .01 FIELD IN PARENT FILE ENTRY
. . . I $P(@(XGL0_BPMTO_",0)"),"^",1)'=BPMTO D
. . . . ;D RSLT^BPMXFIX($J("",2)_"Correcting parent ("_$P(X,";",1)_") entry: "_$G(@(XGL0_BPMTO_",0)")))
. . . . N FDA
. . . . S FDA($P(X,";",4),BPMTO_",",.01)=BPMTO
. . . . D UPDATE^DIE(,"FDA",)
. . . . S BPMCNT3=BPMCNT3+1
. I BPMCNT2+BPMCNT3>0 D RSLT^BPMXFIX(""),HDR^BPMXFIX($$LAST^BPMXFIX(BPMTO),DUZ(2))
. I BPMCNT2 D RSLT^BPMXFIX(" *** Missing Parent Entry Total Found: "_BPMCNT2_" ***")
. I BPMCNT3 D RSLT^BPMXFIX(" *** Incorrect Parent Entry Total Found: "_BPMCNT3_" ***")
;
Q
;
I1 ;EP
;----- REPOINT 'ACCOUNT' FIELD #.01 OF THE 'A/R ACCOUNTS/IHS'
; FILE #90050.02
;
N BPMD0,BPMDUZ2,BPMPTR,DA,X,XIEN,BPMFR,BPMCNT,BPMHDR
;
S BPMDUZ2=$G(DUZ(2)),(XIEN,BPMCNT)=0
F S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN D
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),X=BPMFR_";AUPNPAT(",DUZ(2)=0
. F S DUZ(2)=$O(^BARAC(DUZ(2))) Q:'DUZ(2) D
. . S BPMD0=0,BPMHDR=1
. . F S BPMD0=$O(^BARAC(DUZ(2),"B",X,BPMD0)) Q:'BPMD0 D
. . . N X
. . . S BPMPTR=$P($G(^BARAC(DUZ(2),BPMD0,0)),U)
. . . Q:+BPMPTR'=BPMFR
. . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . . D HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2),BPMD0,BPMHDR)
. . . S BPMHDR=0
. . . S $P(^BARAC(DUZ(2),BPMD0,0),U)=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
. . . S DA=BPMD0,X=BPMFR_";AUPNPAT("
. . . X ^DD(90050.02,.01,1,1,2),^DD(90050.02,.01,1,2,2)
. . . S X=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
. . . X ^DD(90050.02,.01,1,1,1),^DD(90050.02,.01,1,2,1)
. . . S BPMCNT=BPMCNT+1
I BPMDUZ2 S DUZ(2)=BPMDUZ2 ;resetting DUZ(2) back to original value
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
Q
;
I2 ;EP
; ----- REPOINT "GUARANTOR" FIELD (#.01) UNDER GUARANTOR SUBFIELD (#101)
; IN GUARANTOR FILE (#9000043)
;
N BPMD0,BPMD1,BPMPTR,DA,X,XIEN,BPMFR,BPMCNT,BPMHDR
;
S (XIEN,BPMCNT)=0
F S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN D
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),X=BPMFR_";AUPNPAT(",BPMD0=0,BPMHDR=1
. F S BPMD0=$O(^AUPNGUAR("C",X,BPMD0)) Q:'BPMD0 D
. . S BPMD1=0
. . F S BPMD1=$O(^AUPNGUAR("C",X,BPMD0,BPMD1)) Q:'BPMD1 D
. . . N X
. . . S BPMPTR=$P($G(^AUPNGUAR(BPMD0,1,BPMD1,0)),U)
. . . Q:+BPMPTR'=BPMFR
. . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . . D HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2),BPMD0_","_BPMD1,BPMHDR)
. . . S BPMHDR=0
. . . S $P(^AUPNGUAR(BPMD0,1,BPMD1,0),U)=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
. . . S DA(1)=BPMD0,DA=BPMD1,X=BPMFR_";AUPNPAT("
. . . X ^DD(9000043.0101,.01,1,1,2),^DD(9000043.0101,.01,1,2,2)
. . . S X=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
. . . X ^DD(9000043.0101,.01,1,1,1),^DD(9000043.0101,.01,1,2,1)
. . . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
Q
;
I3 ;EP
; ----- REPOINT DESTINATION FIELD (#.127) IN 3P CLAIM DATA FILE
;
N BPMD0,BPMDUZ2,BPMPTR,BPMCNT
;
S (BPMDUZ2,BPMCNT)=0
F S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:'BPMDUZ2 D
. S BPMD0=0
. F S BPMD0=$O(^ABMDCLM(BPMDUZ2,BPMD0)) Q:'BPMD0 D
. . S BPMPTR=$P($G(^ABMDCLM(BPMDUZ2,BPMD0,12)),U,7)
. . Q:'$D(^TMP("BPM",$J,"FROM",+BPMPTR))
. . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . D HDR^BPMXFIX($$LAST^BPMXFIX(+BPMPTR),BPMDUZ2,BPMD0)
. . S $P(^ABMDCLM(BPMDUZ2,BPMD0,12),U,7)=$$LAST^BPMXFIX(+BPMPTR)_";AUPNPAT("
. . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
Q
;
I4 ;EP
; ----- REPOINT DESTINATION FIELD (#.127) IN 3P BILL FILE
;
N BPMD0,BPMDUZ2,BPMPTR,BPMCNT
;
S (BPMDUZ2,BPMCNT)=0
F S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:'BPMDUZ2 D
. S BPMD0=0
. F S BPMD0=$O(^ABMDBILL(BPMDUZ2,BPMD0)) Q:'BPMD0 D
. . S BPMPTR=$P($G(^ABMDBILL(BPMDUZ2,BPMD0,12)),U,7)
. . Q:'$D(^TMP("BPM",$J,"FROM",+BPMPTR))
. . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . D HDR^BPMXFIX($$LAST^BPMXFIX(+BPMPTR),BPMDUZ2,BPMD0)
. . S $P(^ABMDBILL(BPMDUZ2,BPMD0,12),U,7)=$$LAST^BPMXFIX(+BPMPTR)_";AUPNPAT("
. . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
Q
;
V3 ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX ORDER FILE VARIABLE POINTER ENTRIES
;
N BPMD0,BPMPTR,DA,DIK,BPMCNT,I
;
S (BPMD0,BPMCNT)=0
F S BPMD0=$O(^OR(100,BPMD0)) Q:'BPMD0 D
. S BPMPTR=$P($G(^OR(100,BPMD0,0)),U,2)
. Q:'$D(^TMP("BPM",$J,"TO",+BPMPTR))
. Q:$P(BPMPTR,";",2)'="DPT("
. ;
. F I=1:1:$L(^TMP("BPM",$J,"TO",+BPMPTR),"^") D
. . ;----- RESET VARIABLE POINTER -> FROM PATIENT FOR KILL LOGIC
. . S $P(^OR(100,BPMD0,0),U,2)=$P(^TMP("BPM",$J,"TO",+BPMPTR),"^",I)_";DPT("
. . ;
. . ;----- EXECUTE KILL LOGIC FOR XREFS
. . S DIK="^OR(100,",DA=BPMD0
. . D IX2^DIK
. ;
. ;----- RESET VARIABLE POINTER -> TO PATIENT FOR SET LOGIC
. S $P(^OR(100,BPMD0,0),U,2)=$$LAST^BPMXFIX(+BPMPTR)_";DPT("
. ;
. ;----- EXECUTE SET LOGIC FOR XREFS
. S DIK="^OR(100,",DA=BPMD0
. D IX1^DIK
. S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
Q
;
GETXWP ;
N XCNT,XDIEN,I,J,X,XFIL,XNOD,XFLD
F XCNT=1:1:$L(XIENS,"^") D
. S XDIEN=$P(XIENS,"^",XCNT)
. ; ITERATE THROUGH WP FIELDS
. F I=1:1 S X=$P($T(WPFLDS+I),";;",2) Q:X["$$END" D
. . S XFIL=0
. . ; FIND THE MERGE IMAGE FILE
. . F S XFIL=$O(^XDRM(XDIEN,1,XFIL)) Q:+XFIL'=XFIL D
. . . Q:$P(^XDRM(XDIEN,1,XFIL,0),"^",1)'=$P(X,";",1)
. . . S XNOD=0
. . . ; ITERATE THROUGH MERGE IMAGE NODES
. . . F S XNOD=$O(^XDRM(XDIEN,1,XFIL,1,XNOD)) Q:+XNOD'=XNOD D
. . . . ; ITERATE THROUGH WP SUBSCRIPTS
. . . . F J=1:1 S XFLD=$P($P(X,";",3),"^",J) Q:$L(XFLD)<1 D
. . . . . I $NA(@(^XDRM(XDIEN,1,XFIL,1,XNOD,0)),$S($P(X,";",2)[",":3,1:2))=($P(X,";",2)_BPMFR_","_XFLD_")") S @(^XDRM(XDIEN,1,XFIL,1,XNOD,0))=$G(^XDRM(XDIEN,1,XFIL,1,XNOD,1))
Q
WPFLDS ;----- LIST OF WORD PROCESSING FIELDS TO BE MERGED - FILENAME;GBLROOT;SUBSCRPT^
;;PATIENT;AUPNPAT(;12^13^14^15^16;9000001;
;;ASTHMA REGISTER;BATREG(;11;90181.01;
;;MHSS INTAKE;AMHPINTK(;10^11^12^13^14^15^16^17^18^19^21^22^23^24^25^26^27^28^41;9002011.07;
;;BI PATIENT;BIP(;1;9002084;
;;BW PATIENT;BWP(;1;9002086;
;;PHARMACY PATIENT;PS(55,;5.2;55;
;;OUTPATIENT PROFILE;SCPT(404.41,;"C";404.41;
;;ABSP ELIGIBILITY;ABSPE(;"TRANS"^"RESP";9002313.7;
;;$$END
;;GMRY PATIENT I/O FILE;GMR(126,;"IN"^"IV"^"OUT";
BPMXFX2 ;IHS/OIT/NKD - CLEANUP UTILITY - SPLIT INTO MULTIPLE ROUTINES - 6/26/12 ;
+1 ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
+2 ;
+3 QUIT
WP ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX WORD PROCESSING FIELD ENTRIES
+2 ;
+3 NEW BPMTO,BPMCNT,BPMCNT2,BPMCNT3,I,J,X,D1,XIEN,XFLD,XGLFR,XDFR,XGLTO,XGL0,XDTO,XCNT
+4 NEW ABSPE,AMHPINTK,AUPNPAT,BATREG,BIP,BWP,PS,SCPT
+5 ;
+6 SET XIEN="FROM"
+7 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN),-1)
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+8 NEW BPMFR,BPMTO,XIENS,ABSPE,AMHPINTK,AUPNPAT,BATREG,BIP,BWP,PS,SCPT
+9 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET BPMTO=$ORDER(^TMP("BPM",$JOB,XIEN,BPMFR,""))
SET XIENS=$GET(^TMP("BPM",$JOB,XIEN,BPMFR,BPMTO))
SET BPMCNT=0
+10 DO GETXWP
+11 ; ITERATE THROUGH WP FIELDS
+12 FOR I=1:1
SET X=$PIECE($TEXT(WPFLDS+I),";;",2)
IF X["$$END"
QUIT
Begin DoDot:2
+13 ; ITERATE THROUGH WP SUBSCRIPTS
+14 FOR J=1:1
SET XFLD=$PIECE($PIECE(X,";",3),"^",J)
IF $LENGTH(XFLD)<1
QUIT
Begin DoDot:3
+15 SET XGLFR=$PIECE(X,";",2)_BPMFR_","_XFLD
SET XGL0="^"_$PIECE(X,";",2)
SET XGLTO=XGL0_$$LAST^BPMXFIX(BPMFR)_","_XFLD
+16 ; QUIT IF FROM PATIENT DID NOT HAVE DATA
+17 IF '$DATA(@(XGLFR_")"))
QUIT
+18 ; CONCAT WP ARRAYS INTO A STRING
+19 SET XCNT=0
SET XDFR=""
+20 FOR
SET XCNT=$ORDER(@(XGLFR_")")@(XCNT))
IF 'XCNT
QUIT
SET XDFR=XDFR_" "_@(XGLFR_","_XCNT_",0)")
+21 SET XCNT=0
SET XDTO=""
+22 FOR
SET XCNT=$ORDER(@(XGLTO_")")@(XCNT))
IF 'XCNT
QUIT
SET XDTO=XDTO_" "_@(XGLTO_","_XCNT_",0)")
+23 ; CHECK IF THE FROM WP FIELD WAS ALREADY MERGED
+24 IF XDTO[XDFR
QUIT
+25 SET D1=+$PIECE($GET(@(XGLTO_",0)")),U,3)
+26 ;D RSLT^BPMXFIX($J("",2)_"Appending to: "_XGLTO)
+27 ; APPEND TO THE TO PATIENT
+28 SET XCNT=0
+29 FOR
SET XCNT=$ORDER(@(XGLFR_")")@(XCNT))
IF 'XCNT
QUIT
Begin DoDot:4
+30 SET D1=D1+1
+31 SET @(XGLTO_","_D1_",0)")=@(XGLFR_","_XCNT_",0)")
+32 SET $PIECE(@(XGLTO_",0)"),U,3,5)=D1_U_D1_U_$$DT^XLFDT()
End DoDot:4
+33 SET BPMCNT=BPMCNT+1
End DoDot:3
End DoDot:2
+34 IF BPMCNT
DO HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2))
DO RSLT^BPMXFIX(" *** FROM Patient IEN: "_BPMFR_" Total Found: "_BPMCNT_" ***")
End DoDot:1
+35 ;
+36 SET BPMTO=0
+37 FOR
SET BPMTO=$ORDER(^TMP("BPM",$JOB,"TO",BPMTO))
IF +BPMTO'=BPMTO
QUIT
Begin DoDot:1
+38 IF $$LAST^BPMXFIX(BPMTO)'=BPMTO
QUIT
+39 SET (BPMCNT2,BPMCNT3)=0
+40 ; ITERATE THROUGH WP FIELDS
+41 FOR I=1:1
SET X=$PIECE($TEXT(WPFLDS+I),";;",2)
IF X["$$END"
QUIT
Begin DoDot:2
+42 ; ITERATE THROUGH WP SUBSCRIPTS
+43 FOR J=1:1
SET XFLD=$PIECE($PIECE(X,";",3),"^",J)
IF $LENGTH(XFLD)<1
QUIT
Begin DoDot:3
+44 SET XGL0="^"_$PIECE(X,";",2)
SET XGLTO=XGL0_BPMTO_","_XFLD
+45 IF '$DATA(@(XGLTO_",0)"))
QUIT
+46 ; CREATE ENTRY IN PARENT FILE IF IT DOESN'T EXIST
+47 IF '$DATA(@(XGL0_BPMTO_",0)"))
Begin DoDot:4
+48 ;D RSLT^BPMXFIX($J("",2)_"Creating parent ("_$P(X,";",1)_") entry")
+49 NEW ORIEN,FDA,ERR
+50 SET ORIEN(1)=BPMTO
+51 SET FDA($PIECE(X,";",4),"+1,",.01)=BPMTO
+52 DO UPDATE^DIE(,"FDA","ORIEN","ERR")
+53 IF $DATA(ERR)
DO RSLT^BPMXFIX($JUSTIFY("",4)_"ADD FAILED!")
QUIT
+54 SET BPMCNT2=BPMCNT2+1
End DoDot:4
QUIT
+55 ; CORRECT .01 FIELD IN PARENT FILE ENTRY
+56 IF $PIECE(@(XGL0_BPMTO_",0)"),"^",1)'=BPMTO
Begin DoDot:4
+57 ;D RSLT^BPMXFIX($J("",2)_"Correcting parent ("_$P(X,";",1)_") entry: "_$G(@(XGL0_BPMTO_",0)")))
+58 NEW FDA
+59 SET FDA($PIECE(X,";",4),BPMTO_",",.01)=BPMTO
+60 DO UPDATE^DIE(,"FDA",)
+61 SET BPMCNT3=BPMCNT3+1
End DoDot:4
End DoDot:3
End DoDot:2
+62 IF BPMCNT2+BPMCNT3>0
DO RSLT^BPMXFIX("")
DO HDR^BPMXFIX($$LAST^BPMXFIX(BPMTO),DUZ(2))
+63 IF BPMCNT2
DO RSLT^BPMXFIX(" *** Missing Parent Entry Total Found: "_BPMCNT2_" ***")
+64 IF BPMCNT3
DO RSLT^BPMXFIX(" *** Incorrect Parent Entry Total Found: "_BPMCNT3_" ***")
End DoDot:1
+65 ;
+66 QUIT
+67 ;
I1 ;EP
+1 ;----- REPOINT 'ACCOUNT' FIELD #.01 OF THE 'A/R ACCOUNTS/IHS'
+2 ; FILE #90050.02
+3 ;
+4 NEW BPMD0,BPMDUZ2,BPMPTR,DA,X,XIEN,BPMFR,BPMCNT,BPMHDR
+5 ;
+6 SET BPMDUZ2=$GET(DUZ(2))
SET (XIEN,BPMCNT)=0
+7 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN))
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+8 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET X=BPMFR_";AUPNPAT("
SET DUZ(2)=0
+9 FOR
SET DUZ(2)=$ORDER(^BARAC(DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:2
+10 SET BPMD0=0
SET BPMHDR=1
+11 FOR
SET BPMD0=$ORDER(^BARAC(DUZ(2),"B",X,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:3
+12 NEW X
+13 SET BPMPTR=$PIECE($GET(^BARAC(DUZ(2),BPMD0,0)),U)
+14 IF +BPMPTR'=BPMFR
QUIT
+15 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+16 DO HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2),BPMD0,BPMHDR)
+17 SET BPMHDR=0
+18 SET $PIECE(^BARAC(DUZ(2),BPMD0,0),U)=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
+19 SET DA=BPMD0
SET X=BPMFR_";AUPNPAT("
+20 XECUTE ^DD(90050.02,.01,1,1,2)
XECUTE ^DD(90050.02,.01,1,2,2)
+21 SET X=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
+22 XECUTE ^DD(90050.02,.01,1,1,1)
XECUTE ^DD(90050.02,.01,1,2,1)
+23 SET BPMCNT=BPMCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;resetting DUZ(2) back to original value
IF BPMDUZ2
SET DUZ(2)=BPMDUZ2
+25 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+26 QUIT
+27 ;
I2 ;EP
+1 ; ----- REPOINT "GUARANTOR" FIELD (#.01) UNDER GUARANTOR SUBFIELD (#101)
+2 ; IN GUARANTOR FILE (#9000043)
+3 ;
+4 NEW BPMD0,BPMD1,BPMPTR,DA,X,XIEN,BPMFR,BPMCNT,BPMHDR
+5 ;
+6 SET (XIEN,BPMCNT)=0
+7 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN))
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+8 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET X=BPMFR_";AUPNPAT("
SET BPMD0=0
SET BPMHDR=1
+9 FOR
SET BPMD0=$ORDER(^AUPNGUAR("C",X,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+10 SET BPMD1=0
+11 FOR
SET BPMD1=$ORDER(^AUPNGUAR("C",X,BPMD0,BPMD1))
IF 'BPMD1
QUIT
Begin DoDot:3
+12 NEW X
+13 SET BPMPTR=$PIECE($GET(^AUPNGUAR(BPMD0,1,BPMD1,0)),U)
+14 IF +BPMPTR'=BPMFR
QUIT
+15 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+16 DO HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2),BPMD0_","_BPMD1,BPMHDR)
+17 SET BPMHDR=0
+18 SET $PIECE(^AUPNGUAR(BPMD0,1,BPMD1,0),U)=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
+19 SET DA(1)=BPMD0
SET DA=BPMD1
SET X=BPMFR_";AUPNPAT("
+20 XECUTE ^DD(9000043.0101,.01,1,1,2)
XECUTE ^DD(9000043.0101,.01,1,2,2)
+21 SET X=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
+22 XECUTE ^DD(9000043.0101,.01,1,1,1)
XECUTE ^DD(9000043.0101,.01,1,2,1)
+23 SET BPMCNT=BPMCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+24 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+25 QUIT
+26 ;
I3 ;EP
+1 ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P CLAIM DATA FILE
+2 ;
+3 NEW BPMD0,BPMDUZ2,BPMPTR,BPMCNT
+4 ;
+5 SET (BPMDUZ2,BPMCNT)=0
+6 FOR
SET BPMDUZ2=$ORDER(^ABMDCLM(BPMDUZ2))
IF 'BPMDUZ2
QUIT
Begin DoDot:1
+7 SET BPMD0=0
+8 FOR
SET BPMD0=$ORDER(^ABMDCLM(BPMDUZ2,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+9 SET BPMPTR=$PIECE($GET(^ABMDCLM(BPMDUZ2,BPMD0,12)),U,7)
+10 IF '$DATA(^TMP("BPM",$JOB,"FROM",+BPMPTR))
QUIT
+11 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+12 DO HDR^BPMXFIX($$LAST^BPMXFIX(+BPMPTR),BPMDUZ2,BPMD0)
+13 SET $PIECE(^ABMDCLM(BPMDUZ2,BPMD0,12),U,7)=$$LAST^BPMXFIX(+BPMPTR)_";AUPNPAT("
+14 SET BPMCNT=BPMCNT+1
End DoDot:2
End DoDot:1
+15 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+16 QUIT
+17 ;
I4 ;EP
+1 ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P BILL FILE
+2 ;
+3 NEW BPMD0,BPMDUZ2,BPMPTR,BPMCNT
+4 ;
+5 SET (BPMDUZ2,BPMCNT)=0
+6 FOR
SET BPMDUZ2=$ORDER(^ABMDBILL(BPMDUZ2))
IF 'BPMDUZ2
QUIT
Begin DoDot:1
+7 SET BPMD0=0
+8 FOR
SET BPMD0=$ORDER(^ABMDBILL(BPMDUZ2,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+9 SET BPMPTR=$PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,12)),U,7)
+10 IF '$DATA(^TMP("BPM",$JOB,"FROM",+BPMPTR))
QUIT
+11 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+12 DO HDR^BPMXFIX($$LAST^BPMXFIX(+BPMPTR),BPMDUZ2,BPMD0)
+13 SET $PIECE(^ABMDBILL(BPMDUZ2,BPMD0,12),U,7)=$$LAST^BPMXFIX(+BPMPTR)_";AUPNPAT("
+14 SET BPMCNT=BPMCNT+1
End DoDot:2
End DoDot:1
+15 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+16 QUIT
+17 ;
V3 ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX ORDER FILE VARIABLE POINTER ENTRIES
+2 ;
+3 NEW BPMD0,BPMPTR,DA,DIK,BPMCNT,I
+4 ;
+5 SET (BPMD0,BPMCNT)=0
+6 FOR
SET BPMD0=$ORDER(^OR(100,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+7 SET BPMPTR=$PIECE($GET(^OR(100,BPMD0,0)),U,2)
+8 IF '$DATA(^TMP("BPM",$JOB,"TO",+BPMPTR))
QUIT
+9 IF $PIECE(BPMPTR,";",2)'="DPT("
QUIT
+10 ;
+11 FOR I=1:1:$LENGTH(^TMP("BPM",$JOB,"TO",+BPMPTR),"^")
Begin DoDot:2
+12 ;----- RESET VARIABLE POINTER -> FROM PATIENT FOR KILL LOGIC
+13 SET $PIECE(^OR(100,BPMD0,0),U,2)=$PIECE(^TMP("BPM",$JOB,"TO",+BPMPTR),"^",I)_";DPT("
+14 ;
+15 ;----- EXECUTE KILL LOGIC FOR XREFS
+16 SET DIK="^OR(100,"
SET DA=BPMD0
+17 DO IX2^DIK
End DoDot:2
+18 ;
+19 ;----- RESET VARIABLE POINTER -> TO PATIENT FOR SET LOGIC
+20 SET $PIECE(^OR(100,BPMD0,0),U,2)=$$LAST^BPMXFIX(+BPMPTR)_";DPT("
+21 ;
+22 ;----- EXECUTE SET LOGIC FOR XREFS
+23 SET DIK="^OR(100,"
SET DA=BPMD0
+24 DO IX1^DIK
+25 SET BPMCNT=BPMCNT+1
End DoDot:1
+26 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+27 QUIT
+28 ;
GETXWP ;
+1 NEW XCNT,XDIEN,I,J,X,XFIL,XNOD,XFLD
+2 FOR XCNT=1:1:$LENGTH(XIENS,"^")
Begin DoDot:1
+3 SET XDIEN=$PIECE(XIENS,"^",XCNT)
+4 ; ITERATE THROUGH WP FIELDS
+5 FOR I=1:1
SET X=$PIECE($TEXT(WPFLDS+I),";;",2)
IF X["$$END"
QUIT
Begin DoDot:2
+6 SET XFIL=0
+7 ; FIND THE MERGE IMAGE FILE
+8 FOR
SET XFIL=$ORDER(^XDRM(XDIEN,1,XFIL))
IF +XFIL'=XFIL
QUIT
Begin DoDot:3
+9 IF $PIECE(^XDRM(XDIEN,1,XFIL,0),"^",1)'=$PIECE(X,";",1)
QUIT
+10 SET XNOD=0
+11 ; ITERATE THROUGH MERGE IMAGE NODES
+12 FOR
SET XNOD=$ORDER(^XDRM(XDIEN,1,XFIL,1,XNOD))
IF +XNOD'=XNOD
QUIT
Begin DoDot:4
+13 ; ITERATE THROUGH WP SUBSCRIPTS
+14 FOR J=1:1
SET XFLD=$PIECE($PIECE(X,";",3),"^",J)
IF $LENGTH(XFLD)<1
QUIT
Begin DoDot:5
+15 IF $NAME(@(^XDRM(XDIEN,1,XFIL,1,XNOD,0)),$SELECT($PIECE(X,";",2)[",":3,1:2))=($PIECE(X,";",2)_BPMFR_","_XFLD_")")
SET @(^XDRM(XDIEN,1,XFIL,1,XNOD,0))=$GET(^XDRM(XDIEN,1,XFIL,1,XNOD,1))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
WPFLDS ;----- LIST OF WORD PROCESSING FIELDS TO BE MERGED - FILENAME;GBLROOT;SUBSCRPT^
+1 ;;PATIENT;AUPNPAT(;12^13^14^15^16;9000001;
+2 ;;ASTHMA REGISTER;BATREG(;11;90181.01;
+3 ;;MHSS INTAKE;AMHPINTK(;10^11^12^13^14^15^16^17^18^19^21^22^23^24^25^26^27^28^41;9002011.07;
+4 ;;BI PATIENT;BIP(;1;9002084;
+5 ;;BW PATIENT;BWP(;1;9002086;
+6 ;;PHARMACY PATIENT;PS(55,;5.2;55;
+7 ;;OUTPATIENT PROFILE;SCPT(404.41,;"C";404.41;
+8 ;;ABSP ELIGIBILITY;ABSPE(;"TRANS"^"RESP";9002313.7;
+9 ;;$$END
+10 ;;GMRY PATIENT I/O FILE;GMR(126,;"IN"^"IV"^"OUT";
