Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BPMXFX2

BPMXFX2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1. WP ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX WORD PROCESSING FIELD ENTRIES
  1.  ;
  1.  N BPMTO,BPMCNT,BPMCNT2,BPMCNT3,I,J,X,D1,XIEN,XFLD,XGLFR,XDFR,XGLTO,XGL0,XDTO,XCNT
  1.  N ABSPE,AMHPINTK,AUPNPAT,BATREG,BIP,BWP,PS,SCPT
  1.  ;
  1.  S XIEN="FROM"
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN),-1) Q:+XIEN'=XIEN  D
  1.  . N BPMFR,BPMTO,XIENS,ABSPE,AMHPINTK,AUPNPAT,BATREG,BIP,BWP,PS,SCPT
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,"")),XIENS=$G(^TMP("BPM",$J,XIEN,BPMFR,BPMTO)),BPMCNT=0
  1.  . D GETXWP
  1.  . ; ITERATE THROUGH WP FIELDS
  1.  . F I=1:1 S X=$P($T(WPFLDS+I),";;",2) Q:X["$$END"  D
  1.  . . ; ITERATE THROUGH WP SUBSCRIPTS
  1.  . . F J=1:1 S XFLD=$P($P(X,";",3),"^",J) Q:$L(XFLD)<1  D
  1.  . . . S XGLFR=$P(X,";",2)_BPMFR_","_XFLD,XGL0="^"_$P(X,";",2),XGLTO=XGL0_$$LAST^BPMXFIX(BPMFR)_","_XFLD
  1.  . . . ; QUIT IF FROM PATIENT DID NOT HAVE DATA
  1.  . . . Q:'$D(@(XGLFR_")"))
  1.  . . . ; CONCAT WP ARRAYS INTO A STRING
  1.  . . . S XCNT=0,XDFR=""
  1.  . . . F  S XCNT=$O(@(XGLFR_")")@(XCNT)) Q:'XCNT  S XDFR=XDFR_" "_@(XGLFR_","_XCNT_",0)")
  1.  . . . S XCNT=0,XDTO=""
  1.  . . . F  S XCNT=$O(@(XGLTO_")")@(XCNT)) Q:'XCNT  S XDTO=XDTO_" "_@(XGLTO_","_XCNT_",0)")
  1.  . . . ; CHECK IF THE FROM WP FIELD WAS ALREADY MERGED
  1.  . . . Q:XDTO[XDFR
  1.  . . . S D1=+$P($G(@(XGLTO_",0)")),U,3)
  1.  . . . ;D RSLT^BPMXFIX($J("",2)_"Appending to: "_XGLTO)
  1.  . . . ; APPEND TO THE TO PATIENT
  1.  . . . S XCNT=0
  1.  . . . F  S XCNT=$O(@(XGLFR_")")@(XCNT)) Q:'XCNT  D
  1.  . . . . S D1=D1+1
  1.  . . . . S @(XGLTO_","_D1_",0)")=@(XGLFR_","_XCNT_",0)")
  1.  . . . . S $P(@(XGLTO_",0)"),U,3,5)=D1_U_D1_U_$$DT^XLFDT()
  1.  . . . S BPMCNT=BPMCNT+1
  1.  . I BPMCNT D HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2)),RSLT^BPMXFIX("  *** FROM Patient IEN: "_BPMFR_" Total Found: "_BPMCNT_" ***")
  1.  ;
  1.  S BPMTO=0
  1.  F  S BPMTO=$O(^TMP("BPM",$J,"TO",BPMTO)) Q:+BPMTO'=BPMTO  D
  1.  . Q:$$LAST^BPMXFIX(BPMTO)'=BPMTO
  1.  . S (BPMCNT2,BPMCNT3)=0
  1.  . ; ITERATE THROUGH WP FIELDS
  1.  . F I=1:1 S X=$P($T(WPFLDS+I),";;",2) Q:X["$$END"  D
  1.  . . ; ITERATE THROUGH WP SUBSCRIPTS
  1.  . . F J=1:1 S XFLD=$P($P(X,";",3),"^",J) Q:$L(XFLD)<1  D
  1.  . . . S XGL0="^"_$P(X,";",2),XGLTO=XGL0_BPMTO_","_XFLD
  1.  . . . Q:'$D(@(XGLTO_",0)"))
  1.  . . . ; CREATE ENTRY IN PARENT FILE IF IT DOESN'T EXIST
  1.  . . . I '$D(@(XGL0_BPMTO_",0)")) D  Q
  1.  . . . . ;D RSLT^BPMXFIX($J("",2)_"Creating parent ("_$P(X,";",1)_") entry")
  1.  . . . . N ORIEN,FDA,ERR
  1.  . . . . S ORIEN(1)=BPMTO
  1.  . . . . S FDA($P(X,";",4),"+1,",.01)=BPMTO
  1.  . . . . D UPDATE^DIE(,"FDA","ORIEN","ERR")
  1.  . . . . I $D(ERR) D RSLT^BPMXFIX($J("",4)_"ADD FAILED!") Q
  1.  . . . . S BPMCNT2=BPMCNT2+1
  1.  . . . ; CORRECT .01 FIELD IN PARENT FILE ENTRY
  1.  . . . I $P(@(XGL0_BPMTO_",0)"),"^",1)'=BPMTO D
  1.  . . . . ;D RSLT^BPMXFIX($J("",2)_"Correcting parent ("_$P(X,";",1)_") entry: "_$G(@(XGL0_BPMTO_",0)")))
  1.  . . . . N FDA
  1.  . . . . S FDA($P(X,";",4),BPMTO_",",.01)=BPMTO
  1.  . . . . D UPDATE^DIE(,"FDA",)
  1.  . . . . S BPMCNT3=BPMCNT3+1
  1.  . I BPMCNT2+BPMCNT3>0 D RSLT^BPMXFIX(""),HDR^BPMXFIX($$LAST^BPMXFIX(BPMTO),DUZ(2))
  1.  . I BPMCNT2 D RSLT^BPMXFIX("  *** Missing Parent Entry Total Found: "_BPMCNT2_" ***")
  1.  . I BPMCNT3 D RSLT^BPMXFIX("  *** Incorrect Parent Entry Total Found: "_BPMCNT3_" ***")
  1.  ;
  1.  Q
  1.  ;
  1. I1 ;EP
  1.  ;----- REPOINT 'ACCOUNT' FIELD #.01 OF THE 'A/R ACCOUNTS/IHS' 
  1.  ;      FILE #90050.02
  1.  ;
  1.  N BPMD0,BPMDUZ2,BPMPTR,DA,X,XIEN,BPMFR,BPMCNT,BPMHDR
  1.  ;
  1.  S BPMDUZ2=$G(DUZ(2)),(XIEN,BPMCNT)=0
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN  D
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),X=BPMFR_";AUPNPAT(",DUZ(2)=0
  1.  . F  S DUZ(2)=$O(^BARAC(DUZ(2))) Q:'DUZ(2)  D
  1.  . . S BPMD0=0,BPMHDR=1
  1.  . . F  S BPMD0=$O(^BARAC(DUZ(2),"B",X,BPMD0)) Q:'BPMD0  D
  1.  . . . N X
  1.  . . . S BPMPTR=$P($G(^BARAC(DUZ(2),BPMD0,0)),U)
  1.  . . . Q:+BPMPTR'=BPMFR
  1.  . . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . . D HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2),BPMD0,BPMHDR)
  1.  . . . S BPMHDR=0
  1.  . . . S $P(^BARAC(DUZ(2),BPMD0,0),U)=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
  1.  . . . S DA=BPMD0,X=BPMFR_";AUPNPAT("
  1.  . . . X ^DD(90050.02,.01,1,1,2),^DD(90050.02,.01,1,2,2)
  1.  . . . S X=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
  1.  . . . X ^DD(90050.02,.01,1,1,1),^DD(90050.02,.01,1,2,1)
  1.  . . . S BPMCNT=BPMCNT+1
  1.  I BPMDUZ2 S DUZ(2)=BPMDUZ2    ;resetting DUZ(2) back to original value
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  Q
  1.  ;
  1. I2 ;EP
  1.  ; ----- REPOINT "GUARANTOR" FIELD (#.01) UNDER GUARANTOR SUBFIELD (#101)
  1.  ;         IN GUARANTOR FILE (#9000043)
  1.  ;
  1.  N BPMD0,BPMD1,BPMPTR,DA,X,XIEN,BPMFR,BPMCNT,BPMHDR
  1.  ;
  1.  S (XIEN,BPMCNT)=0
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN  D
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),X=BPMFR_";AUPNPAT(",BPMD0=0,BPMHDR=1
  1.  . F  S BPMD0=$O(^AUPNGUAR("C",X,BPMD0)) Q:'BPMD0  D
  1.  . . S BPMD1=0
  1.  . . F  S BPMD1=$O(^AUPNGUAR("C",X,BPMD0,BPMD1)) Q:'BPMD1  D
  1.  . . . N X
  1.  . . . S BPMPTR=$P($G(^AUPNGUAR(BPMD0,1,BPMD1,0)),U)
  1.  . . . Q:+BPMPTR'=BPMFR
  1.  . . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . . D HDR^BPMXFIX($$LAST^BPMXFIX(BPMFR),DUZ(2),BPMD0_","_BPMD1,BPMHDR)
  1.  . . . S BPMHDR=0
  1.  . . . S $P(^AUPNGUAR(BPMD0,1,BPMD1,0),U)=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
  1.  . . . S DA(1)=BPMD0,DA=BPMD1,X=BPMFR_";AUPNPAT("
  1.  . . . X ^DD(9000043.0101,.01,1,1,2),^DD(9000043.0101,.01,1,2,2)
  1.  . . . S X=$$LAST^BPMXFIX(BPMFR)_";AUPNPAT("
  1.  . . . X ^DD(9000043.0101,.01,1,1,1),^DD(9000043.0101,.01,1,2,1)
  1.  . . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  Q
  1.  ;
  1. I3 ;EP
  1.  ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P CLAIM DATA FILE
  1.  ;
  1.  N BPMD0,BPMDUZ2,BPMPTR,BPMCNT
  1.  ;
  1.  S (BPMDUZ2,BPMCNT)=0
  1.  F  S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:'BPMDUZ2  D
  1.  . S BPMD0=0
  1.  . F  S BPMD0=$O(^ABMDCLM(BPMDUZ2,BPMD0)) Q:'BPMD0  D
  1.  . . S BPMPTR=$P($G(^ABMDCLM(BPMDUZ2,BPMD0,12)),U,7)
  1.  . . Q:'$D(^TMP("BPM",$J,"FROM",+BPMPTR))
  1.  . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . D HDR^BPMXFIX($$LAST^BPMXFIX(+BPMPTR),BPMDUZ2,BPMD0)
  1.  . . S $P(^ABMDCLM(BPMDUZ2,BPMD0,12),U,7)=$$LAST^BPMXFIX(+BPMPTR)_";AUPNPAT("
  1.  . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  Q
  1.  ;
  1. I4 ;EP
  1.  ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P BILL FILE
  1.  ;
  1.  N BPMD0,BPMDUZ2,BPMPTR,BPMCNT
  1.  ;
  1.  S (BPMDUZ2,BPMCNT)=0
  1.  F  S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:'BPMDUZ2  D
  1.  . S BPMD0=0
  1.  . F  S BPMD0=$O(^ABMDBILL(BPMDUZ2,BPMD0)) Q:'BPMD0  D
  1.  . . S BPMPTR=$P($G(^ABMDBILL(BPMDUZ2,BPMD0,12)),U,7)
  1.  . . Q:'$D(^TMP("BPM",$J,"FROM",+BPMPTR))
  1.  . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . D HDR^BPMXFIX($$LAST^BPMXFIX(+BPMPTR),BPMDUZ2,BPMD0)
  1.  . . S $P(^ABMDBILL(BPMDUZ2,BPMD0,12),U,7)=$$LAST^BPMXFIX(+BPMPTR)_";AUPNPAT("
  1.  . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  Q
  1.  ;
  1. V3 ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX ORDER FILE VARIABLE POINTER ENTRIES
  1.  ;
  1.  N BPMD0,BPMPTR,DA,DIK,BPMCNT,I
  1.  ;
  1.  S (BPMD0,BPMCNT)=0
  1.  F  S BPMD0=$O(^OR(100,BPMD0)) Q:'BPMD0  D
  1.  . S BPMPTR=$P($G(^OR(100,BPMD0,0)),U,2)
  1.  . Q:'$D(^TMP("BPM",$J,"TO",+BPMPTR))
  1.  . Q:$P(BPMPTR,";",2)'="DPT("
  1.  . ;
  1.  . F I=1:1:$L(^TMP("BPM",$J,"TO",+BPMPTR),"^")  D
  1.  . . ;----- RESET VARIABLE POINTER -> FROM PATIENT FOR KILL LOGIC
  1.  . . S $P(^OR(100,BPMD0,0),U,2)=$P(^TMP("BPM",$J,"TO",+BPMPTR),"^",I)_";DPT("
  1.  . . ;
  1.  . . ;----- EXECUTE KILL LOGIC FOR XREFS
  1.  . . S DIK="^OR(100,",DA=BPMD0
  1.  . . D IX2^DIK
  1.  . ;
  1.  . ;----- RESET VARIABLE POINTER -> TO PATIENT FOR SET LOGIC
  1.  . S $P(^OR(100,BPMD0,0),U,2)=$$LAST^BPMXFIX(+BPMPTR)_";DPT("
  1.  . ;
  1.  . ;----- EXECUTE SET LOGIC FOR XREFS
  1.  . S DIK="^OR(100,",DA=BPMD0
  1.  . D IX1^DIK
  1.  . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  Q
  1.  ;
  1. GETXWP ;
  1.  N XCNT,XDIEN,I,J,X,XFIL,XNOD,XFLD
  1.  F XCNT=1:1:$L(XIENS,"^") D
  1.  . S XDIEN=$P(XIENS,"^",XCNT)
  1.  . ; ITERATE THROUGH WP FIELDS
  1.  . F I=1:1 S X=$P($T(WPFLDS+I),";;",2) Q:X["$$END"  D
  1.  . . S XFIL=0
  1.  . . ; FIND THE MERGE IMAGE FILE
  1.  . . F  S XFIL=$O(^XDRM(XDIEN,1,XFIL)) Q:+XFIL'=XFIL  D
  1.  . . . Q:$P(^XDRM(XDIEN,1,XFIL,0),"^",1)'=$P(X,";",1)
  1.  . . . S XNOD=0
  1.  . . . ; ITERATE THROUGH MERGE IMAGE NODES
  1.  . . . F  S XNOD=$O(^XDRM(XDIEN,1,XFIL,1,XNOD)) Q:+XNOD'=XNOD  D
  1.  . . . . ; ITERATE THROUGH WP SUBSCRIPTS
  1.  . . . . F J=1:1 S XFLD=$P($P(X,";",3),"^",J) Q:$L(XFLD)<1  D
  1.  . . . . . 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))
  1.  Q
  1. WPFLDS ;----- LIST OF WORD PROCESSING FIELDS TO BE MERGED - FILENAME;GBLROOT;SUBSCRPT^
  1.  ;;PATIENT;AUPNPAT(;12^13^14^15^16;9000001;
  1.  ;;ASTHMA REGISTER;BATREG(;11;90181.01;
  1.  ;;MHSS INTAKE;AMHPINTK(;10^11^12^13^14^15^16^17^18^19^21^22^23^24^25^26^27^28^41;9002011.07;
  1.  ;;BI PATIENT;BIP(;1;9002084;
  1.  ;;BW PATIENT;BWP(;1;9002086;
  1.  ;;PHARMACY PATIENT;PS(55,;5.2;55;
  1.  ;;OUTPATIENT PROFILE;SCPT(404.41,;"C";404.41;
  1.  ;;ABSP ELIGIBILITY;ABSPE(;"TRANS"^"RESP";9002313.7;
  1.  ;;$$END
  1.  ;;GMRY PATIENT I/O FILE;GMR(126,;"IN"^"IV"^"OUT";