APSPEC16 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;27-Sep-2013 11:23;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1016**;Sep 23, 2004;Build 74
;
ENV ;EP
;
S X=$$GET1^DIQ(200,DUZ,.01)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_", Patch 1016.",IOM)
S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 ; Suppress the Disable options and Move routines prompts
S XPDABORT=0
I 'XPDABORT D
.W !!,"All requirements for installation have been met...",!
E D
.W !!,"Unable to continue with the installation...",!
Q
;
MES(TXT,QUIT) ;EP
D BMES^XPDUTL(" "_$G(TXT))
S:$G(QUIT) XPDABORT=QUIT
Q
;
PRE ;EP - Pre-init
N DIU
S DIU=9009033.91,DIU(0)="" D EN^DIU2
S DIU=9009033.7,DIU(0)="D" D EN^DIU2
D RENXPAR("APSP SS REFILL REQUEST","APSP SS RENEW REQUEST")
Q
RENXPAR(OLD,NEW) ; Rename parameter
N IEN,FDA,FIL
S FIL=8989.51
Q:$$FIND1^DIC(FIL,,"X",NEW) ; New name already exists
S IEN=$$FIND1^DIC(FIL,,"X",OLD)
Q:'IEN ; Old name doesn't exist
S FDA(FIL,IEN_",",.01)=NEW
D FILE^DIE("E","FDA")
Q
;
REMXPAR(PAR) ;Remove values stored for a given parameter
N PIEN,ENT,INT,VIEN,DIK,DA
S PIEN=$O(^XPAR(8989.51,"B",PAR,0))
Q:'PIEN
S ENT=0 F S ENT=$O(^XPAR(8989.5,"AC",PIEN,ENT)) Q:ENT="" D ;Entity
.S INT=0 F S INT=$O(^XPAR(8989.5,"AC",PIEN,ENT,INT)) Q:INT="" D ;Instance
..S DA=0 F S DA=$O(^XPAR(8989.5,"AC",PIEN,ENT,INT,DA)) Q:'DA D ;Value IEN
...S DIK="^XTV(8989.5," D ^DIK
Q
POST ;EP
;Move the zero node of the APSP REFILL FILE to the 1 node and rebuild zero node
D FIXNODE
D MM
D DELETE^XPDMENU("APSP MAIN MENU","APSP XPAR AUTOFINISH MAIN")
D DELETE^XPDMENU("APSP MAIN MENU","APSP REFILL REQUESTS")
D FIXVMEDD()
D LNAME
D XREF
D FIXLBL
D EN^XPAR("SYS","APSP SS PHARMACY MAILORDER",,"YES")
N DATA,INSDT
I $$INSTALDT^XPDUTL("APSP*7.0*1013",.DATA) D
.S INSDT=$P($O(DATA(0)),".")
.D FIXEXP(INSDT)
Q
;
XREF ;EP-
N DIK
S DIK=$$ROOT^DILFD(9009033.91)
S DIK(1)=".01"
D ENALL^DIK
Q
; Add given namespace to Application
AAPPGRP(FILE,NMSP) ;EP
N FDA,IEN,ERR
Q:'$G(FILE)!('$L(NMSP))
S FDA(1.005,"?+1,"_FILE_",",.01)=NMSP
D UPDATE^DIE("","FDA","IEN","ERR")
Q
; Register a protocol to an extended action protocol
; Input: P-Parent protocol
; C-Child protocol
; SEQ-Sequence Number
REGPROT(P,C,SEQ,ERR) ;EP
N IENARY,PIEN,AIEN,FDA
D
.I '$L(P)!('$L(C)) S ERR="Missing input parameter" Q
.S IENARY(1)=$$FIND1^DIC(101,"","",P)
.S AIEN=$$FIND1^DIC(101,"","",C)
.I 'IENARY(1)!'AIEN S ERR="Unknown protocol name" Q
.S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN
.S FDA(101.01,"?+2,"_IENARY(1)_",",3)=SEQ
.D UPDATE^DIE("S","FDA","IENARY","ERR")
;Q:$Q $G(ERR)=""
Q
; UnRegister a protocol from an extended action protocol
; Input: P-Parent protocol
; C-Child protocol
UREGPROT(P,C,ERR) ;EP-
N IENARY,PIEN,AIEN,FDA
D
.I '$L(P)!('$L(C)) S ERR="Missing input parameter" Q
.S IENARY(1)=$$FIND1^DIC(101,"","",P)
.S AIEN=$$FIND1^DIC(101,"","",C)
.I 'IENARY(1)!'AIEN S ERR="Unknown protocol name" Q
.S IENARY(2)=$$FIND1^DIC(101.01,","_IENARY(1)_",","",C)
.S FDA(101.01,IENARY(2)_","_IENARY(1)_",",.01)="@"
.D UPDATE^DIE("S","FDA","","ERR")
Q
SETPKGV(PKG,VER) ;EP
N PIEN,FDA
S PIEN=$$FIND1^DIC(9.4,,,PKG)
Q:'PIEN
S FDA(9.4,PIEN_",",13)=VER
D UPDATE^DIE(,"FDA")
Q
; Cleanup Drug File DD
CLN50DD ;EP -
S DIU=50.03,DIU(0)="SD" D EN^DIU2
Q
; Fix Out of Order Message and lock with APSP Key
OFOMSG(OPT,MSG,KEY) ;
N IEN,VAL,FDA,KIEN
S IEN=$$FIND1^DIC(19,,"X",OPT)
S KIEN=$$FIND1^DIC(19.1,,"X",KEY)
I IEN D
.S VAL=$S($L($G(MSG)):MSG,1:"Not used in IHS")
.S FDA(19,IEN_",",2)=VAL
.S:KIEN FDA(19,IEN_",",3)=KIEN
.D FILE^DIE("K","FDA")
Q
; Cleanup PCC Link in NVA node
CLNNVA ;EP -
N DFN,IEN,FDA,NVAERR
S DFN=0 F S DFN=$O(^PS(55,"APCC","+1",DFN)) Q:'DFN D
.S IEN=0 F S IEN=$O(^PS(55,"APCC","+1",DFN,IEN)) Q:'IEN D
..S FDA(55.05,IEN_","_DFN_",",9999999.11)="@"
D:$D(FDA) UPDATE^DIE("","FDA",,"NVAERR")
W:$G(DIERR) $G(NVAERR("DIERR",1,"TEXT",1))
Q
;
FIXEXP(INSDT) ; EP-
N FDT,RX,DRG,EXTEXP,X2,NEXPDT,ISSDT,RX0
S FDT=INSDT-.01 F S FDT=$O(^PSRX("AD",FDT)) Q:'FDT D
.S RX=0 F S RX=$O(^PSRX("AD",FDT,RX)) Q:'RX D
..Q:'$$RMNRFL^APSPFUNC(RX) ;quit if no remaining fills
..N DA,DR,DIE
..S RX0=^PSRX(RX,0)
..S DRG=+$P(RX0,U,6)
..S ISSDT=$P(RX0,U,13)
..Q:'$$ISSCH^APSPFNC2(DRG,"345") ;quit if not a schedule 3-5 drug
..S EXTEXP=$$GET1^DIQ(50,DRG,9999999.08)
..S X2=$S(EXTEXP:EXTEXP,1:184)
..S NEXPDT=$$FMADD^XLFDT(ISSDT,X2)
..S DA=RX,DIE="^PSRX("
..S DR="26///"_NEXPDT D ^DIE
..W !,"Fixed Expiration date for RX IEN: "_RX
Q
FIXNODE ;EP
N IEN,NODE,INST,FN,FDA,IENS,ERR,DOSE,DISP,UNITS,UNIT,NOUN
S FN=9009033.912
S IEN=0 F S IEN=$O(^APSPRREQ(IEN)) Q:'+IEN D
.S INST=0 F S INST=$O(^APSPRREQ(IEN,2,INST)) Q:'+INST D
..S IENS=INST_","_IEN_","
..S NODE=$G(^APSPRREQ(IEN,2,INST,0))
..Q:$D(^APSPRREQ(IEN,2,INST,1)) ;Quit if already converted
..S DOSE=$P(NODE,U,1)
..S FDA(FN,IENS,1.1)=DOSE ;Dosage ordered
..S DISP=$P(NODE,U,2)
..S FDA(FN,IENS,1.2)=DISP ;Dispense per dose
..S UNITS=$P(NODE,U,3)
..S UNIT=$$GET1^DIQ(50.607,UNITS,.01)
..S FDA(FN,IENS,1.3)=UNIT ;Units
..S NOUN=$P(NODE,U,4)
..S FDA(FN,IENS,1.4)=NOUN ;noun
..S FDA(FN,IENS,1.5)=$P(NODE,U,5) ;duration
..S FDA(FN,IENS,1.6)=$P(NODE,U,6) ;conjunction
..S FDA(FN,IENS,1.7)=$P(NODE,U,7) ;route
..S FDA(FN,IENS,1.8)=$P(NODE,U,8) ;schedule
..S FDA(FN,IENS,1.9)=$P(NODE,U,9) ;route
..;S FDA(FN,IENS,.01)=DOSE_"&"_UNIT_"&"_DISP_"&"_NOUN_"&"_DOSE_UNIT
..D UPDATE^DIE("","FDA","IENS","ERR")
..S ^APSPRREQ(IEN,2,INST,0)=DOSE_"&"_UNIT_"&"_DISP_"&"_NOUN_"&"_DOSE_UNIT
..K FDA,IENS,ERR
..K ^APSPRREQ(IEN,2,"B",DOSE,INST)
Q
;
FIXLBL ;EP check for missing data in label
N RDTE,RX
S RDTE=3130301
F S RDTE=$O(^PSRX("AC",RDTE)) Q:RDTE="" D
.S RX="" F S RX=$O(^PSRX("AC",RDTE,RX)) Q:RX="" D
..D FIXLBL1(RX)
Q
FIXLBL1(RX) ;Check label nodes
N LBL,NODE,TYPE
S LBL="" F S LBL=$O(^PSRX(RX,"L",LBL)) Q:LBL="" D
.S NODE=$G(^PSRX(RX,"L",LBL,0))
.I $P(NODE,U,4)="" S TYPE=$P(NODE,U,2) D FIXLBL2(LBL,RX,TYPE)
Q
FIXLBL2(LBL,RX,TYPE) ;Update missing data
N USER,AIEN,FDA,ERR
S USER=""
I TYPE=0 D
.S USER=$P($G(^PSRX(RX,"OR1")),"^",5)
.I USER="" S USER=$P($G(^PSRX(RX,2)),"^",3)
I TYPE>0 D
.S USER=$P($G(^PSRX(RX,1,TYPE,0)),U,7)
.I USER="" S USER=$P($G(^PSRX(RX,1,TYPE,0)),U,5)
I USER'="" D
.S AIEN=LBL_","_RX_","
.S FDA(52.032,AIEN,3)=USER
.D UPDATE^DIE("","FDA","AIEN","ERR")
Q
; Fix VMed entries lacking Date Discontinued
FIXVMEDD(DAYS) ;EP -
N RX,BDT,EDT,FDT,VMED,ACT
S EDT=$$DT^XLFDT()
S BDT=$$FMADD^XLFDT(EDT,-$G(DAYS,730))
S FDTLP=BDT-.01
F S FDTLP=$O(^PSRX("AD",FDTLP)) Q:'FDTLP!(FDTLP>EDT) D
.S RX=0
.F S RX=$O(^PSRX("AD",FDTLP,RX)) Q:'RX D
..Q:$G(^PSRX(RX,"STA"))'=15 ;status not Discontinued (Edit)
..S VMED=+$G(^PSRX(RX,999999911))
..Q:'VMED
..Q:$P($G(^AUPNVMED(VMED,0)),U,8) ;already marked as discontinued
..;Check last activity node for a discontinued type
..S ACT=$P($G(^PSRX(RX,"A",0)),U,4)
..Q:'ACT
..S ACT=$G(^PSRX(RX,"A",ACT,0))
..I $P(ACT,U,2)="C" D
...S $P(^AUPNVMED(VMED,0),U,8)=$P(+ACT,".")
Q
LNAME ;Loop through drugs and copy generic name to long name field
N DRG,LNAME,NAM,FNUM
S DRG=0 F S DRG=$O(^PSDRUG(DRG)) Q:'+DRG D
.S NAM=$$GET1^DIQ(50,DRG,.01)
.Q:NAM=""
.S LNAME=$$GET1^DIQ(50,DRG,9999999.352)
.Q:LNAME'=""
.N FDA,IEN,ERR
.S IEN=DRG_","
.S FDA(50,IEN,9999999.352)=NAM
.D UPDATE^DIE("","FDA","IEN","ERR")
Q
; Send Quantity Qualifier MailMan message
MM ;EP-
N LP,XMTEXT,XMY,XMSUB,XMDUZ,DA,DIFROM,CNT,DATA
N QQARY,DNM,QQNM,STR,X
K ^TMP("DATA",$J)
F LP=0:1 S X=$P($T(IENS+LP),";;",2) Q:'$L(X) D
.D SEARCH(+X)
I $D(^TMP("DATA",$J)) D
.S DATA=$NA(^TMP("APSP1016Z",$J))
.K @DATA
.S XMTEXT="^TMP(""APSP1016Z"",$J,"
.S XMDUZ="NDF MANAGER"
.S XMSUB="DRUGS ASSOCIATED WITH INACTIVATED QUANTITY QUALIFIERS"
.D BLDTXT
.S CNT=7
.S DNM="" F S DNM=$O(^TMP("DATA",$J,DNM)) Q:DNM="" D
..S QQNM="" F S QQNM=$O(^TMP("DATA",$J,DNM,QQNM)) Q:QQNM="" D
...S X=^TMP("DATA",$J,DNM,QQNM)
...S STR=DNM,$E(STR,52)=+X,$E(STR,59)=QQNM
...S CNT=CNT+1
...S @DATA@(CNT)=STR
.S DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
.S XMY("G.NDF DATA@"_^XMB("NETNAME"))=""
.D ^XMD
Q
;
;Add fixed text to message global
BLDTXT ;EP-
S @DATA@(1)="The following entries in your DRUG file (#50) are associated with"
S @DATA@(2)="NCPDP Quantity Qualifiers in the APSP NCPDP Control Codes file."
S @DATA@(3)="It is critical that you rematch these products immediately so that"
S @DATA@(4)="the Surescripts interface will continue to work without errors."
S @DATA@(5)=""
S @DATA@(6)="DRUG IEN QTY QUALIFIER"
S @DATA@(7)=""
Q
SEARCH(QQ) ;EP- Given qualifier return list of drug file entries linked to quantity qualifier
N DIEN,DRGQQ
S DIEN=0 F S DIEN=$O(^PSDRUG(DIEN)) Q:'DIEN D
.S DRGQQ=+$P($G(^PSDRUG(DIEN,9999999.145)),U)
.Q:DRGQQ'=QQ
.S ^TMP("DATA",$J,$$GET1^DIQ(50,DIEN,.01),$$GET1^DIQ(9009033.7,QQ,.01))=DIEN_U_QQ_U_$$GET1^DIQ(9009033.7,QQ,1)
Q
IENS ;;147
;;150
;;154
;;155
;;167
;;
APSPEC16 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;27-Sep-2013 11:23;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1016**;Sep 23, 2004;Build 74
+2 ;
ENV ;EP
+1 ;
+2 SET X=$$GET1^DIQ(200,DUZ,.01)
+3 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+4 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_", Patch 1016.",IOM)
+5 ; Suppress the Disable options and Move routines prompts
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+6 SET XPDABORT=0
+7 IF 'XPDABORT
Begin DoDot:1
+8 WRITE !!,"All requirements for installation have been met...",!
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 WRITE !!,"Unable to continue with the installation...",!
End DoDot:1
+11 QUIT
+12 ;
MES(TXT,QUIT) ;EP
+1 DO BMES^XPDUTL(" "_$GET(TXT))
+2 IF $GET(QUIT)
SET XPDABORT=QUIT
+3 QUIT
+4 ;
PRE ;EP - Pre-init
+1 NEW DIU
+2 SET DIU=9009033.91
SET DIU(0)=""
DO EN^DIU2
+3 SET DIU=9009033.7
SET DIU(0)="D"
DO EN^DIU2
+4 DO RENXPAR("APSP SS REFILL REQUEST","APSP SS RENEW REQUEST")
+5 QUIT
RENXPAR(OLD,NEW) ; Rename parameter
+1 NEW IEN,FDA,FIL
+2 SET FIL=8989.51
+3 ; New name already exists
IF $$FIND1^DIC(FIL,,"X",NEW)
QUIT
+4 SET IEN=$$FIND1^DIC(FIL,,"X",OLD)
+5 ; Old name doesn't exist
IF 'IEN
QUIT
+6 SET FDA(FIL,IEN_",",.01)=NEW
+7 DO FILE^DIE("E","FDA")
+8 QUIT
+9 ;
REMXPAR(PAR) ;Remove values stored for a given parameter
+1 NEW PIEN,ENT,INT,VIEN,DIK,DA
+2 SET PIEN=$ORDER(^XPAR(8989.51,"B",PAR,0))
+3 IF 'PIEN
QUIT
+4 ;Entity
SET ENT=0
FOR
SET ENT=$ORDER(^XPAR(8989.5,"AC",PIEN,ENT))
IF ENT=""
QUIT
Begin DoDot:1
+5 ;Instance
SET INT=0
FOR
SET INT=$ORDER(^XPAR(8989.5,"AC",PIEN,ENT,INT))
IF INT=""
QUIT
Begin DoDot:2
+6 ;Value IEN
SET DA=0
FOR
SET DA=$ORDER(^XPAR(8989.5,"AC",PIEN,ENT,INT,DA))
IF 'DA
QUIT
Begin DoDot:3
+7 SET DIK="^XTV(8989.5,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
POST ;EP
+1 ;Move the zero node of the APSP REFILL FILE to the 1 node and rebuild zero node
+2 DO FIXNODE
+3 DO MM
+4 DO DELETE^XPDMENU("APSP MAIN MENU","APSP XPAR AUTOFINISH MAIN")
+5 DO DELETE^XPDMENU("APSP MAIN MENU","APSP REFILL REQUESTS")
+6 DO FIXVMEDD()
+7 DO LNAME
+8 DO XREF
+9 DO FIXLBL
+10 DO EN^XPAR("SYS","APSP SS PHARMACY MAILORDER",,"YES")
+11 NEW DATA,INSDT
+12 IF $$INSTALDT^XPDUTL("APSP*7.0*1013",.DATA)
Begin DoDot:1
+13 SET INSDT=$PIECE($ORDER(DATA(0)),".")
+14 DO FIXEXP(INSDT)
End DoDot:1
+15 QUIT
+16 ;
XREF ;EP-
+1 NEW DIK
+2 SET DIK=$$ROOT^DILFD(9009033.91)
+3 SET DIK(1)=".01"
+4 DO ENALL^DIK
+5 QUIT
+6 ; Add given namespace to Application
AAPPGRP(FILE,NMSP) ;EP
+1 NEW FDA,IEN,ERR
+2 IF '$GET(FILE)!('$LENGTH(NMSP))
QUIT
+3 SET FDA(1.005,"?+1,"_FILE_",",.01)=NMSP
+4 DO UPDATE^DIE("","FDA","IEN","ERR")
+5 QUIT
+6 ; Register a protocol to an extended action protocol
+7 ; Input: P-Parent protocol
+8 ; C-Child protocol
+9 ; SEQ-Sequence Number
REGPROT(P,C,SEQ,ERR) ;EP
+1 NEW IENARY,PIEN,AIEN,FDA
+2 Begin DoDot:1
+3 IF '$LENGTH(P)!('$LENGTH(C))
SET ERR="Missing input parameter"
QUIT
+4 SET IENARY(1)=$$FIND1^DIC(101,"","",P)
+5 SET AIEN=$$FIND1^DIC(101,"","",C)
+6 IF 'IENARY(1)!'AIEN
SET ERR="Unknown protocol name"
QUIT
+7 SET FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN
+8 SET FDA(101.01,"?+2,"_IENARY(1)_",",3)=SEQ
+9 DO UPDATE^DIE("S","FDA","IENARY","ERR")
End DoDot:1
+10 ;Q:$Q $G(ERR)=""
+11 QUIT
+12 ; UnRegister a protocol from an extended action protocol
+13 ; Input: P-Parent protocol
+14 ; C-Child protocol
UREGPROT(P,C,ERR) ;EP-
+1 NEW IENARY,PIEN,AIEN,FDA
+2 Begin DoDot:1
+3 IF '$LENGTH(P)!('$LENGTH(C))
SET ERR="Missing input parameter"
QUIT
+4 SET IENARY(1)=$$FIND1^DIC(101,"","",P)
+5 SET AIEN=$$FIND1^DIC(101,"","",C)
+6 IF 'IENARY(1)!'AIEN
SET ERR="Unknown protocol name"
QUIT
+7 SET IENARY(2)=$$FIND1^DIC(101.01,","_IENARY(1)_",","",C)
+8 SET FDA(101.01,IENARY(2)_","_IENARY(1)_",",.01)="@"
+9 DO UPDATE^DIE("S","FDA","","ERR")
End DoDot:1
+10 QUIT
SETPKGV(PKG,VER) ;EP
+1 NEW PIEN,FDA
+2 SET PIEN=$$FIND1^DIC(9.4,,,PKG)
+3 IF 'PIEN
QUIT
+4 SET FDA(9.4,PIEN_",",13)=VER
+5 DO UPDATE^DIE(,"FDA")
+6 QUIT
+7 ; Cleanup Drug File DD
CLN50DD ;EP -
+1 SET DIU=50.03
SET DIU(0)="SD"
DO EN^DIU2
+2 QUIT
+3 ; Fix Out of Order Message and lock with APSP Key
OFOMSG(OPT,MSG,KEY) ;
+1 NEW IEN,VAL,FDA,KIEN
+2 SET IEN=$$FIND1^DIC(19,,"X",OPT)
+3 SET KIEN=$$FIND1^DIC(19.1,,"X",KEY)
+4 IF IEN
Begin DoDot:1
+5 SET VAL=$SELECT($LENGTH($GET(MSG)):MSG,1:"Not used in IHS")
+6 SET FDA(19,IEN_",",2)=VAL
+7 IF KIEN
SET FDA(19,IEN_",",3)=KIEN
+8 DO FILE^DIE("K","FDA")
End DoDot:1
+9 QUIT
+10 ; Cleanup PCC Link in NVA node
CLNNVA ;EP -
+1 NEW DFN,IEN,FDA,NVAERR
+2 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"APCC","+1",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^PS(55,"APCC","+1",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 SET FDA(55.05,IEN_","_DFN_",",9999999.11)="@"
End DoDot:2
End DoDot:1
+5 IF $DATA(FDA)
DO UPDATE^DIE("","FDA",,"NVAERR")
+6 IF $GET(DIERR)
WRITE $GET(NVAERR("DIERR",1,"TEXT",1))
+7 QUIT
+8 ;
FIXEXP(INSDT) ; EP-
+1 NEW FDT,RX,DRG,EXTEXP,X2,NEXPDT,ISSDT,RX0
+2 SET FDT=INSDT-.01
FOR
SET FDT=$ORDER(^PSRX("AD",FDT))
IF 'FDT
QUIT
Begin DoDot:1
+3 SET RX=0
FOR
SET RX=$ORDER(^PSRX("AD",FDT,RX))
IF 'RX
QUIT
Begin DoDot:2
+4 ;quit if no remaining fills
IF '$$RMNRFL^APSPFUNC(RX)
QUIT
+5 NEW DA,DR,DIE
+6 SET RX0=^PSRX(RX,0)
+7 SET DRG=+$PIECE(RX0,U,6)
+8 SET ISSDT=$PIECE(RX0,U,13)
+9 ;quit if not a schedule 3-5 drug
IF '$$ISSCH^APSPFNC2(DRG,"345")
QUIT
+10 SET EXTEXP=$$GET1^DIQ(50,DRG,9999999.08)
+11 SET X2=$SELECT(EXTEXP:EXTEXP,1:184)
+12 SET NEXPDT=$$FMADD^XLFDT(ISSDT,X2)
+13 SET DA=RX
SET DIE="^PSRX("
+14 SET DR="26///"_NEXPDT
DO ^DIE
+15 WRITE !,"Fixed Expiration date for RX IEN: "_RX
End DoDot:2
End DoDot:1
+16 QUIT
FIXNODE ;EP
+1 NEW IEN,NODE,INST,FN,FDA,IENS,ERR,DOSE,DISP,UNITS,UNIT,NOUN
+2 SET FN=9009033.912
+3 SET IEN=0
FOR
SET IEN=$ORDER(^APSPRREQ(IEN))
IF '+IEN
QUIT
Begin DoDot:1
+4 SET INST=0
FOR
SET INST=$ORDER(^APSPRREQ(IEN,2,INST))
IF '+INST
QUIT
Begin DoDot:2
+5 SET IENS=INST_","_IEN_","
+6 SET NODE=$GET(^APSPRREQ(IEN,2,INST,0))
+7 ;Quit if already converted
IF $DATA(^APSPRREQ(IEN,2,INST,1))
QUIT
+8 SET DOSE=$PIECE(NODE,U,1)
+9 ;Dosage ordered
SET FDA(FN,IENS,1.1)=DOSE
+10 SET DISP=$PIECE(NODE,U,2)
+11 ;Dispense per dose
SET FDA(FN,IENS,1.2)=DISP
+12 SET UNITS=$PIECE(NODE,U,3)
+13 SET UNIT=$$GET1^DIQ(50.607,UNITS,.01)
+14 ;Units
SET FDA(FN,IENS,1.3)=UNIT
+15 SET NOUN=$PIECE(NODE,U,4)
+16 ;noun
SET FDA(FN,IENS,1.4)=NOUN
+17 ;duration
SET FDA(FN,IENS,1.5)=$PIECE(NODE,U,5)
+18 ;conjunction
SET FDA(FN,IENS,1.6)=$PIECE(NODE,U,6)
+19 ;route
SET FDA(FN,IENS,1.7)=$PIECE(NODE,U,7)
+20 ;schedule
SET FDA(FN,IENS,1.8)=$PIECE(NODE,U,8)
+21 ;route
SET FDA(FN,IENS,1.9)=$PIECE(NODE,U,9)
+22 ;S FDA(FN,IENS,.01)=DOSE_"&"_UNIT_"&"_DISP_"&"_NOUN_"&"_DOSE_UNIT
+23 DO UPDATE^DIE("","FDA","IENS","ERR")
+24 SET ^APSPRREQ(IEN,2,INST,0)=DOSE_"&"_UNIT_"&"_DISP_"&"_NOUN_"&"_DOSE_UNIT
+25 KILL FDA,IENS,ERR
+26 KILL ^APSPRREQ(IEN,2,"B",DOSE,INST)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
FIXLBL ;EP check for missing data in label
+1 NEW RDTE,RX
+2 SET RDTE=3130301
+3 FOR
SET RDTE=$ORDER(^PSRX("AC",RDTE))
IF RDTE=""
QUIT
Begin DoDot:1
+4 SET RX=""
FOR
SET RX=$ORDER(^PSRX("AC",RDTE,RX))
IF RX=""
QUIT
Begin DoDot:2
+5 DO FIXLBL1(RX)
End DoDot:2
End DoDot:1
+6 QUIT
FIXLBL1(RX) ;Check label nodes
+1 NEW LBL,NODE,TYPE
+2 SET LBL=""
FOR
SET LBL=$ORDER(^PSRX(RX,"L",LBL))
IF LBL=""
QUIT
Begin DoDot:1
+3 SET NODE=$GET(^PSRX(RX,"L",LBL,0))
+4 IF $PIECE(NODE,U,4)=""
SET TYPE=$PIECE(NODE,U,2)
DO FIXLBL2(LBL,RX,TYPE)
End DoDot:1
+5 QUIT
FIXLBL2(LBL,RX,TYPE) ;Update missing data
+1 NEW USER,AIEN,FDA,ERR
+2 SET USER=""
+3 IF TYPE=0
Begin DoDot:1
+4 SET USER=$PIECE($GET(^PSRX(RX,"OR1")),"^",5)
+5 IF USER=""
SET USER=$PIECE($GET(^PSRX(RX,2)),"^",3)
End DoDot:1
+6 IF TYPE>0
Begin DoDot:1
+7 SET USER=$PIECE($GET(^PSRX(RX,1,TYPE,0)),U,7)
+8 IF USER=""
SET USER=$PIECE($GET(^PSRX(RX,1,TYPE,0)),U,5)
End DoDot:1
+9 IF USER'=""
Begin DoDot:1
+10 SET AIEN=LBL_","_RX_","
+11 SET FDA(52.032,AIEN,3)=USER
+12 DO UPDATE^DIE("","FDA","AIEN","ERR")
End DoDot:1
+13 QUIT
+14 ; Fix VMed entries lacking Date Discontinued
FIXVMEDD(DAYS) ;EP -
+1 NEW RX,BDT,EDT,FDT,VMED,ACT
+2 SET EDT=$$DT^XLFDT()
+3 SET BDT=$$FMADD^XLFDT(EDT,-$GET(DAYS,730))
+4 SET FDTLP=BDT-.01
+5 FOR
SET FDTLP=$ORDER(^PSRX("AD",FDTLP))
IF 'FDTLP!(FDTLP>EDT)
QUIT
Begin DoDot:1
+6 SET RX=0
+7 FOR
SET RX=$ORDER(^PSRX("AD",FDTLP,RX))
IF 'RX
QUIT
Begin DoDot:2
+8 ;status not Discontinued (Edit)
IF $GET(^PSRX(RX,"STA"))'=15
QUIT
+9 SET VMED=+$GET(^PSRX(RX,999999911))
+10 IF 'VMED
QUIT
+11 ;already marked as discontinued
IF $PIECE($GET(^AUPNVMED(VMED,0)),U,8)
QUIT
+12 ;Check last activity node for a discontinued type
+13 SET ACT=$PIECE($GET(^PSRX(RX,"A",0)),U,4)
+14 IF 'ACT
QUIT
+15 SET ACT=$GET(^PSRX(RX,"A",ACT,0))
+16 IF $PIECE(ACT,U,2)="C"
Begin DoDot:3
+17 SET $PIECE(^AUPNVMED(VMED,0),U,8)=$PIECE(+ACT,".")
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
LNAME ;Loop through drugs and copy generic name to long name field
+1 NEW DRG,LNAME,NAM,FNUM
+2 SET DRG=0
FOR
SET DRG=$ORDER(^PSDRUG(DRG))
IF '+DRG
QUIT
Begin DoDot:1
+3 SET NAM=$$GET1^DIQ(50,DRG,.01)
+4 IF NAM=""
QUIT
+5 SET LNAME=$$GET1^DIQ(50,DRG,9999999.352)
+6 IF LNAME'=""
QUIT
+7 NEW FDA,IEN,ERR
+8 SET IEN=DRG_","
+9 SET FDA(50,IEN,9999999.352)=NAM
+10 DO UPDATE^DIE("","FDA","IEN","ERR")
End DoDot:1
+11 QUIT
+12 ; Send Quantity Qualifier MailMan message
MM ;EP-
+1 NEW LP,XMTEXT,XMY,XMSUB,XMDUZ,DA,DIFROM,CNT,DATA
+2 NEW QQARY,DNM,QQNM,STR,X
+3 KILL ^TMP("DATA",$JOB)
+4 FOR LP=0:1
SET X=$PIECE($TEXT(IENS+LP),";;",2)
IF '$LENGTH(X)
QUIT
Begin DoDot:1
+5 DO SEARCH(+X)
End DoDot:1
+6 IF $DATA(^TMP("DATA",$JOB))
Begin DoDot:1
+7 SET DATA=$NAME(^TMP("APSP1016Z",$JOB))
+8 KILL @DATA
+9 SET XMTEXT="^TMP(""APSP1016Z"",$J,"
+10 SET XMDUZ="NDF MANAGER"
+11 SET XMSUB="DRUGS ASSOCIATED WITH INACTIVATED QUANTITY QUALIFIERS"
+12 DO BLDTXT
+13 SET CNT=7
+14 SET DNM=""
FOR
SET DNM=$ORDER(^TMP("DATA",$JOB,DNM))
IF DNM=""
QUIT
Begin DoDot:2
+15 SET QQNM=""
FOR
SET QQNM=$ORDER(^TMP("DATA",$JOB,DNM,QQNM))
IF QQNM=""
QUIT
Begin DoDot:3
+16 SET X=^TMP("DATA",$JOB,DNM,QQNM)
+17 SET STR=DNM
SET $EXTRACT(STR,52)=+X
SET $EXTRACT(STR,59)=QQNM
+18 SET CNT=CNT+1
+19 SET @DATA@(CNT)=STR
End DoDot:3
End DoDot:2
+20 SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
IF 'DA
QUIT
SET XMY(DA)=""
+21 SET XMY("G.NDF DATA@"_^XMB("NETNAME"))=""
+22 DO ^XMD
End DoDot:1
+23 QUIT
+24 ;
+25 ;Add fixed text to message global
BLDTXT ;EP-
+1 SET @DATA@(1)="The following entries in your DRUG file (#50) are associated with"
+2 SET @DATA@(2)="NCPDP Quantity Qualifiers in the APSP NCPDP Control Codes file."
+3 SET @DATA@(3)="It is critical that you rematch these products immediately so that"
+4 SET @DATA@(4)="the Surescripts interface will continue to work without errors."
+5 SET @DATA@(5)=""
+6 SET @DATA@(6)="DRUG IEN QTY QUALIFIER"
+7 SET @DATA@(7)=""
+8 QUIT
SEARCH(QQ) ;EP- Given qualifier return list of drug file entries linked to quantity qualifier
+1 NEW DIEN,DRGQQ
+2 SET DIEN=0
FOR
SET DIEN=$ORDER(^PSDRUG(DIEN))
IF 'DIEN
QUIT
Begin DoDot:1
+3 SET DRGQQ=+$PIECE($GET(^PSDRUG(DIEN,9999999.145)),U)
+4 IF DRGQQ'=QQ
QUIT
+5 SET ^TMP("DATA",$JOB,$$GET1^DIQ(50,DIEN,.01),$$GET1^DIQ(9009033.7,QQ,.01))=DIEN_U_QQ_U_$$GET1^DIQ(9009033.7,QQ,1)
End DoDot:1
+6 QUIT
IENS ;;147
+1 ;;150
+2 ;;154
+3 ;;155
+4 ;;167
+5 ;;
