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

BQI23POS.m

Go to the documentation of this file. 
  1. BQI23POS ;VNGT/HS/ALA - Version 2.3 PostInstall ; 20 May 2011  2:00 PM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
  1.  ;
  1.  ;
  1. EN ;
  1.  ;Set the version number
  1.  NEW DA
  1.  S DA=$O(^BQI(90508,0))
  1.  S BQIUPD(90508,DA_",",.08)="2.3.0.26"
  1.  S BQIUPD(90508,DA_",",.09)="2.3.0T26"
  1.  S BQIUPD(90508,DA_",",11)="IPC3"
  1.  S BQIUPD(90508,DA_",",11.02)=1
  1.  S BQIUPD(90508,DA_",",.07)=1
  1.  I $G(^BQI(90508,DA,16))="" S BQIUPD(90508,DA_",",16.01)="L"
  1.  ;
  1.  ;Set the timeout values
  1.  S BQIUPD(90508,DA_",",.21)="60"
  1.  S BQIUPD(90508,DA_",",.22)="5"
  1.  S BQIUPD(90508,DA_",",.23)="60"
  1.  ;
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  ;
  1.  NEW NDZ
  1.  S NDZ=0
  1.  F  S NDZ=$O(^BQICARE(NDZ)) Q:'NDZ  D
  1.  . I $P($G(^BQICARE(NDZ,2)),U,5)="" D
  1.  .. S BQIUPD(90505,NDZ_",",2.05)=$$FIND1^DIC(90506.4,"","BX","Patient List","","","ERROR")
  1.  .. S BQIUPD(90505,NDZ_",",2.06)="N"
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  ;
  1.  ;Set the group order parm to no
  1.  NEW DA,BQIUPD,ERROR
  1.  S DA=$$SPM^BQIGPUTL()
  1.  S BQIUPD(90508,DA_",",.2)="@"
  1.  I $D(BQIUPD) D FILE^DIE("E","BQIUPD","ERROR")
  1.  K DA,BQIUPD,ERROR
  1.  ;
  1.  ;For CANES 2.0 
  1.  ;D DX^BQI202PU
  1.  ;
  1.  ; Set BTPWRPC into BQIRPC
  1.  NEW IEN,DA,X,DIC,Y
  1.  S DA(1)=$$FIND1^DIC(19,"","B","BQIRPC","","","ERROR"),DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="LMNZ"
  1.  I $G(^DIC(19,DA(1),10,0))="" S ^DIC(19,DA(1),10,0)="^19.01IP^^"
  1.  S X="BTPWRPC"
  1.  D ^DIC I +Y<1 K DO,DD D FILE^DICN
  1.  ;
  1.  ; Add reports to menu
  1.  S X=$$ADD^XPDMENU("APCL IPC REPORTS MENU","BQI IPC MISMATCH PROV","MIS")
  1.  S X=$$ADD^XPDMENU("APCL IPC REPORTS MENU","BQI IPC PROVIDER COUNT","CNT")
  1.  ;
  1.  ; Convert pointers to codes
  1.  NEW NDZ,NPL,CRN,OVL,OVAL,SHZ
  1.  S NDZ=0
  1.  F  S NDZ=$O(^BQICARE(NDZ)) Q:'NDZ  D
  1.  . I $G(^BQICARE(NDZ,0))="" K ^BQICARE(NDZ) Q
  1.  . S NPL=0
  1.  . F  S NPL=$O(^BQICARE(NDZ,1,NPL)) Q:'NPL  D
  1.  .. S CRN=0
  1.  .. F  S CRN=$O(^BQICARE(NDZ,1,NPL,20,CRN)) Q:'CRN  D
  1.  ... S OVAL=$P(^BQICARE(NDZ,1,NPL,20,CRN,0),"^",1)
  1.  ... I OVAL'?.N Q
  1.  ... NEW DA,IENS
  1.  ... S DA(2)=NDZ,DA(1)=NPL,DA=CRN,IENS=$$IENS^DILF(.DA)
  1.  ... S BQIUPD(90505.05,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
  1.  .. S CRN=0
  1.  .. F  S CRN=$O(^BQICARE(NDZ,1,NPL,23,CRN)) Q:'CRN  D
  1.  ... S IEN=0
  1.  ... F  S IEN=$O(^BQICARE(NDZ,1,NPL,23,CRN,1,IEN)) Q:'IEN  D
  1.  .... S OVAL=$P(^BQICARE(NDZ,1,NPL,23,CRN,1,IEN,0),"^",1)
  1.  .... I OVAL'?.N Q
  1.  .... NEW DA,IENS
  1.  .... S DA(3)=NDZ,DA(2)=NPL,DA(1)=CRN,DA=IEN,IENS=$$IENS^DILF(.DA)
  1.  .... S BQIUPD(90505.1231,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
  1.  .. S SHZ=0
  1.  .. F  S SHZ=$O(^BQICARE(NDZ,1,NPL,30,SHZ)) Q:'SHZ  D
  1.  ... S CRN=0
  1.  ... F  S CRN=$O(^BQICARE(NDZ,1,NPL,30,SHZ,20,CRN)) Q:'CRN  D
  1.  .... S OVAL=$P(^BQICARE(NDZ,1,NPL,30,SHZ,20,CRN,0),"^",1)
  1.  .... I OVAL'?.N Q
  1.  .... NEW DA,IENS
  1.  .... S DA(3)=NDZ,DA(2)=NPL,DA(1)=SHZ,DA=CRN,IENS=$$IENS^DILF(.DA)
  1.  .... S BQIUPD(90505.06,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
  1.  ... S CRN=0
  1.  ... F  S CRN=$O(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN)) Q:'CRN  D
  1.  .... S IEN=0
  1.  .... F  S IEN=$O(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN,1,IEN)) Q:'IEN  D
  1.  ..... S OVAL=$P(^BQICARE(NDZ,1,NPL,30,SHZ,23,CRN,1,IEN,0),"^",1)
  1.  ..... I OVAL'?.N Q
  1.  ..... NEW DA,IENS
  1.  ..... S DA(4)=NDZ,DA(3)=NPL,DA(2)=SHZ,DA(1)=CRN,DA=IEN,IENS=$$IENS^DILF(.DA)
  1.  ..... S BQIUPD(90505.3231,IENS,.01)=$P(^BQI(90506.1,OVAL,0),U,1)
  1.  . I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  ; 
  1.  ; Add new patient entries to 90506.1
  1.  NEW BI,BJ,BK,BN,BQIUPD,ERROR,IEN,ND,NDATA,TEXT,VAL
  1.  F BI=1:1 S TEXT=$P($T(LYT+BI),";;",2) Q:TEXT=""  D
  1.  . F BJ=1:1:$L(TEXT,"~") D
  1.  .. S NDATA=$P(TEXT,"~",BJ)
  1.  .. S ND=$P(NDATA,"|",1),VAL=$P(NDATA,"|",2)
  1.  .. I ND=0 D
  1.  ... NEW DIC,X,Y
  1.  ... S DIC(0)="LQZ",DIC="^BQI(90506.1,",X=$P(VAL,U,1)
  1.  ... D ^DIC
  1.  ... S IEN=+Y
  1.  ... I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
  1.  .. I ND=1 S BQIUPD(90506.1,IEN_",",1)=VAL Q
  1.  .. F BK=1:1:$L(VAL,"^") D
  1.  ... S BN=$O(^DD(90506.1,"GL",ND,BK,"")) I BN="" Q
  1.  ... I $P(VAL,"^",BK)'="" S BQIUPD(90506.1,IEN_",",BN)=$P(VAL,"^",BK) Q
  1.  ... I $P(VAL,"^",BK)="" S BQIUPD(90506.1,IEN_",",BN)="@"
  1.  . D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1.  ; Re-Index File
  1.  K ^BQI(90506.1,"AC"),^BQI(90506.1,"AD")
  1.  NEW DIK
  1.  S DIK="^BQI(90506.1,",DIK(1)=3.01
  1.  D ENALL^DIK
  1.  ;
  1.  ; Update IPC measures
  1.  D ^BQI23PU
  1.  ;
  1.  ; Fix Template Pointer Issues
  1.  D FIX()
  1.  ;
  1.  ;Regenerate Panel Descriptions
  1.  D PDESC()
  1.  ;
  1.  ;Make Reproductive Factors Definition fields Active/Inactive
  1.  D UVDEF^BQIPTRP1()
  1.  ;
  1. IP ; Fix Outcome Bundle update
  1.  I $D(^BQI(90508,1,22,1,3,"B",3120200)) D
  1.  . D DM^BQIIPOTC(1,32,3120200,"IPC_DMCTRL","")
  1.  . D LD^BQIIPOTC(1,57,3120200,"IPC_LDCTRL","")
  1.  . D BP^BQIIPOTC(1,58,3120200,"IPC_BPCTRL","")
  1.  . D EN^BQIIPOTC(3120200)
  1.  . D GS(3120200)
  1.  ;
  1.  I $D(^BQI(90508,1,22,1,3,"B",3120300)) D
  1.  . D DM^BQIIPOTC(1,32,3120300,"IPC_DMCTRL","")
  1.  . D LD^BQIIPOTC(1,57,3120300,"IPC_LDCTRL","")
  1.  . D BP^BQIIPOTC(1,58,3120300,"IPC_BPCTRL","")
  1.  . D EN^BQIIPOTC(3120300)
  1.  . D GS(3120300)
  1.  ;
  1. MU ; Run MU Provider data for first Monthly periods
  1.  ; Clean up old data
  1.  S PRV=0 F  S PRV=$O(^BQIPROV(PRV)) Q:'PRV  K ^BQIPROV(PRV,11),^BQIPROV(PRV,21),^BQIPROV(PRV,60),^BQIPROV(PRV,50)
  1.  S FAC=$O(^BQIFAC(0)) I FAC'="" K ^BQIFAC(FAC,11),^BQIFAC(FAC,21),^BQIFAC(FAC,60),^BQIFAC(FAC,50)
  1.  ;
  1.  D
  1.  . NEW BQDT,FAC,BQTMN,BQNO,CDTM
  1.  . S BQDT=$E(DT,1,5)_"00"
  1.  . S FAC=$$HME^BQIGPUTL()
  1.  . S BQTMN=$O(^BQIFAC(FAC,50,"B",BQDT,""))
  1.  . D CKM
  1.  . I BQTMN="",'BQNO D EN^BQIMUMON($E(DT,1,5)_"01")
  1.  . I BQTMN="",BQNO S ^XTMP("BQIMMON",$E(DT,1,5)_"01")=""
  1.  . S ^XTMP("BQIMMON",0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"Month list"
  1.  . S CDTM=$E(DT,4,5)
  1.  . F BI=7:1:12 S ^XTMP("BQIMMON","311"_$S(BI<10:"0"_BI,1:BI)_"01")=""
  1.  . I $E(DT,1,3)>311 F BI=1:1:CDTM S ^XTMP("BQIMMON","312"_$S(BI<10:"0"_BI,1:BI)_"01")=""
  1.  ;
  1. RSC ; Remove the scheduled tasks
  1.  NEW RPC,OPTN,OPN,LIST,ZTSK
  1.  F RPC="BQI UPDATE MU CQM 1 YEAR","BQI UPDATE MU CQM 90 DAYS" D
  1.  . S OPTN=$$FIND^BQISCHED(RPC)
  1.  . I OPTN'>0 Q
  1.  . S OPN=$O(^DIC(19.2,"B",OPTN,""))
  1.  . I OPN'="" D
  1.  .. NEW DA,DIK
  1.  .. S DIK="^DIC(19.2,",DA=OPN D ^DIK
  1.  . NEW DA,DIK
  1.  . S DA=OPTN,DIK="^DIC(19," D ^DIK
  1.  . K LIST
  1.  . D OPTION^%ZTLOAD(RPC,.LIST)
  1.  . S ZTSK=""
  1.  . F  S ZTSK=$O(@LIST@(ZTSK)) Q:ZTSK=""  D
  1.  .. D PCLEAR^%ZTLOAD(ZTSK)
  1.  .. D KILL^%ZTLOAD
  1.  Q
  1.  ;
  1. GS(BQDATE)  ; Update the Goal Set
  1.  NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
  1.  S PRV="",YEAR=$$GET1^DIQ(90508,1_",",2,"E")
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . S TPRN=$O(^BQIPROV(PRV,30,"B","IPC_TOTP","")) I TPRN="" Q
  1.  . S TPRD=$O(^BQIPROV(PRV,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
  1.  . S GPRN=$O(^BQIPROV(PRV,30,"B",YEAR_"_2452","")) I GPRN="" Q
  1.  . S GPRD=$O(^BQIPROV(PRV,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
  1.  . S DEN=$P(^BQIPROV(PRV,30,TPRN,1,TPRD,0),U,2)
  1.  . S $P(^BQIPROV(PRV,30,GPRN,1,GPRD,0),U,2)=DEN
  1.  S FAC=$$HME^BQIGPUTL()
  1.  S TPRN=$O(^BQIFAC(FAC,30,"B","IPC_TOTP","")) I TPRN="" Q
  1.  S TPRD=$O(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
  1.  S GPRN=$O(^BQIFAC(FAC,30,"B",YEAR_"_2452","")) I GPRN="" Q
  1.  S GPRD=$O(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
  1.  S DEN=$P(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
  1.  S $P(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
  1.  Q
  1.  ;
  1. PDESC() ;EP - Regenerate Panel Descriptions
  1.  NEW USER,PLIEN
  1.  S USER=0 F  S USER=$O(^BQICARE(USER)) Q:'USER  D
  1.  . S PLIEN=0 F  S PLIEN=$O(^BQICARE(USER,1,PLIEN)) Q:'PLIEN  D
  1.  .. NEW DESC,DA,IENS
  1.  .. S DA(1)=USER,DA=PLIEN,IENS=$$IENS^DILF(.DA)
  1.  .. D DESC^BQIPDSCM(USER,PLIEN,.DESC)
  1.  .. D WP^DIE(90505.01,IENS,5,"","DESC")
  1.  Q
  1.  ;
  1. FIX() ;EP - FIX INVALID TEMPLATE POINTERS
  1.  ;
  1.  NEW USER,PLIEN,TIEN,SHR
  1.  S USER=0 F  S USER=$O(^BQICARE(USER)) Q:'USER  D
  1.  . S PLIEN=0 F  S PLIEN=$O(^BQICARE(USER,1,PLIEN)) Q:'PLIEN  D
  1.  .. S TIEN=0 F  S TIEN=$O(^BQICARE(USER,1,PLIEN,4,TIEN)) Q:'TIEN  D
  1.  ... NEW DA,IENS,TEMPL,DIC,X,Y,DIK
  1.  ... S DA(2)=USER,DA(1)=PLIEN,DA=TIEN,IENS=$$IENS^DILF(.DA)
  1.  ... S TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"I")
  1.  ... S X=TEMPL,DIC="^BQICARE("_USER_",15,",DIC(0)="X"
  1.  ... D ^DIC
  1.  ... I +Y>0 Q
  1.  ... S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",4,"
  1.  ... D ^DIK
  1.  .. ;
  1.  .. ;Look for templates in use in shared panels
  1.  .. S SHR=0 F  S SHR=$O(^BQICARE(USER,1,PLIEN,30,SHR)) Q:'SHR  D
  1.  ... S TIEN=0 F  S TIEN=$O(^BQICARE(USER,1,PLIEN,30,SHR,4,TIEN)) Q:'TIEN  D
  1.  .... NEW DA,IENS,TEMPL,DIC,X,Y,DIK
  1.  .... S DA(3)=USER,DA(2)=PLIEN,DA(1)=SHR,DA=TIEN,IENS=$$IENS^DILF(.DA)
  1.  .... S TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"I")
  1.  .... S X=TEMPL,DIC="^BQICARE("_USER_",15,",DIC(0)="X"
  1.  .... D ^DIC
  1.  .... I +Y>0 Q
  1.  .... S DIK="^BQICARE("_DA(3)_",1,"_DA(2)_",30,"_DA(1)_",4,"
  1.  .... D ^DIK
  1.  ;
  1.  Q
  1.  ;
  1. CKM ;EP - Check for existing job
  1.  NEW LIST,TSK,ZTSK
  1.  D DESC^%ZTLOAD("MU CQ Monthly Compile",.LIST)
  1.  S TSK="",BQNO=0
  1.  F  S TSK=$O(@LIST@(TSK)) Q:TSK=""  S ZTSK=TSK D STAT^%ZTLOAD I ZTSK(2)["Active" S BQNO=1
  1.  Q
  1.  ;
  1. LYT ;EP - Layout items
  1.  ;;0|EMPL^^Employer^^9000001^.19^^T00060EMPL~1|~3|1^^Other Patient Data^O^42^^^^^BQIZEMPHLTH~5|
  1.  ;;0|LVDPCP^^Last Visit Date w DPCP^^^^^D00030LVDPCP~1|S VAL=$$LVDPCP^BQIULPT(DFN)~3|1^^Visit Related^O^16^^^D~5|
  1.  ;;