ABSPOSII ; IHS/SD/RLT - DIAGNOSIS CODES form ; [ 06/21/2007 9:30 AM ]
;;1.0;PHARMACY POINT OF SALE;**23,45,48**;JUN 21, 2007;Build 38
;
Q
PREINIT ;EP - check for existing record
; This is the pre-init routine tied to ScreenMan form ABSP INPUT 1
; page 25 DIAGNOSIS CODE 5.1 ENTRY.
; This is used during the creation of the "NEW" claim from
; within POS (called from the "USER" screen) to capture
; DIAGNOSIS CODE values.
;
;OIT/CAS/RCS 06072012 Patch 45 - Use Diagnosis lookup for ICD9/ICD10 Implementation
;
N RXI,RXR,DIAG,FDA,STRING
;
; get the prescription information
S RXI=$$GET^DDSVAL(DIE,.DA,1.01) ;RX IEN
S RXR=$$GET^DDSVAL(DIE,.DA,1.02) ;RX Refill IEN
S DIAG=""
;
Q:$G(RXI)="" ;no pres - get out
;
S DIAG=$$GETDIAG^ABSPOSO(RXI,RXR) ;get DIAGNOSIS CODE pointer
;
I $G(DIAG)'="" D ;DIANOSIS CODE exists
. S STRING(1)="Will add diagnosis code from IEN RX "_RXI ;msg on scrn
. S:+RXR STRING(1)=STRING(1)_" IEN Refill "_RXR
. D HLP^DDSUTL(.STRING) ;displays what is happening
. ;
I $G(DIAG)="" D ;diagnosis code doesn't exist yet
. S DIAG=$$NEW^ABSPOSD3
. S STRING(1)="Will add new diagnosis code "_DIAG
. D HLP^DDSUTL(.STRING)
;
; create empty entries for adding new data
D NEWSUB^ABSPOSD3(DIAG)
;
; now- update the input data file and the prescription
;POINTERS REMOVED FROM PRESCRIPTION FILE
;D UPDRX(RXI,RXR,DIAG)
D PUT^DDSVAL(DIE,.DA,1.15,DIAG,,"I")
;
; theres a chance they won't file the claim - hold on to the
; DIAG so we can clean up empty records if its not filed
;
S ^TMP("ABSPOSII",$J,DIAG)=RXI_"^"_RXR
;
N VMED
Q
;
CLNDIAG(IEN,ENTRY) ;EP from ABSPOSIZ
; clean up the DIAG file of empty entries
; and update the RX file when no override information
; was actually entered for the 5.1 DIAG segment.
; This routine called from ABSPOSIZ - subroutine FILE
;
N DIAG,DATAREC
;
S DATAREC=$G(^ABSP(9002313.51,IEN,2,ENTRY,1))
;
S DIAG=$P(DATAREC,"^",12)
Q:DIAG="" ;just quit
;
S RXI=$P(DATAREC,"^")
S RXR=$P(DATAREC,"^",2)
;
S DIAG=$$CHKDIAG^ABSPOSD3(DIAG) ;good data input?
;
I $G(DIAG)="" D ;nothing input - delete it
. ;POINTERS REMOVED FROM PRESCRIPTION FILE
. ;D UPDRX(RXI,RXR,DIAG)
. N FDA,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
. S FDA(9002313.51,ENTRY_","_IEN_",",1.15)=DIAG
. D FILE^DIE("","FDA","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
. I $D(ZERR) D LOG^ABSPOSL2("CLNDIAG^ABSPOSII",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
D DIAGCNT(DIAG) ;update DIAG count after cleaning
;
Q
;
UPDRX(RXI,RXR,DIAG) ;POINTERS REMOVED FROM PRESCRIPTION FILE
; update the prescription with the DIAG 5.1 information
; and the ABSP Data Input file with the appropriate value
;
; N FDA,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
;
; DIAG set within POSTINIT
; RXR - rx refill IEN
; RXI - rx IEN
; DIAG - NCPDP 5.1 DIAG segment pointer
;
;I '+$G(RXR) D ;NOT a refill
;. S FDA(52,RXI_",",9999999.17)=DIAG
;. D FILE^DIE("","FDA","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
;. I $D(ZERR) D LOG^ABSPOSL2("UPDRX+13^ABSPOSII",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
;I +$G(RXR) D ;refill
;. S FDA(52.1,RXR_","_RXI_",",9999999.17)=DIAG
;. D FILE^DIE("","FDA","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
;. I $D(ZERR) D LOG^ABSPOSL2("UPDRX+18^ABSPOSII",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
Q
;
NOCLM ;EP - called from ABSPOSI when the claims are NOT filed - we
; still must clean up the empty records if they called upon
; the DIAGNOSIS CODES entry
;
N DIAGIEN,CLNDIAG,DIAGREC,RXI,RXR
;
S DIAGIEN=0
F S DIAGIEN=$O(^TMP("ABSPOSII",$J,DIAGIEN)) Q:DIAGIEN="" D
. S DIAGREC=$G(^TMP("ABSPOSII",$J,DIAGIEN))
. S RXI=$P(DIAGREC,"^") ;internal RX number
. S RXR=$P(DIAGREC,"^",2) ;refill number
. S CLNDIAG=$$CHKDIAG^ABSPOSD3(DIAGIEN)
. ;POINTERS REMOVED FROM PRESCRIPTION FILE
. ;D:$G(CLNDIAG)="" UPDRX(RXI,RXR,CLNDIAG)
;
Q
DIAGCNT(DIAG) ;
;
Q:DIAG=""
;
N DIAGIEN,DIAGCNT,DIAGCNTR
;
S (DIAGIEN,DIAGCNT,DIAGCNTR)=0
F S DIAGIEN=$O(^ABSP(9002313.491,DIAG,1,DIAGIEN)) Q:'+DIAGIEN D
. S DIAGCNT=DIAGCNT+1
. S DIAGCNTR=$P($G(^ABSP(9002313.491,DIAG,1,DIAGIEN,0)),U)
. I DIAGCNTR'=DIAGCNT D
. . D CNTFIX(9002313.4911,DIAG,DIAGIEN,DIAGCNT)
;
S $P(^ABSP(9002313.491,DIAG,0),U,5)=DIAGCNT
Q
CNTFIX(FILE,REC,SUB,CNT) ;
;
N FDA
S FDA(FILE,SUB_","_REC_",",.01)=CNT
CNTFILE ;
D FILE^DIE("","FDA","MSG")
I $D(MSG) D LOG^ABSPOSL2("CNTFILE^ABSPOSII",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
G:$D(MSG) CNTFILE:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"CNTFILE",$T(+0))
;
Q
HELP492 ;EP - Help code for file #9002313.491 - ABSP DIAGNOSIS
; field #492 - DIAGNOSIS CODE QUALIFIER
N EFFDT,X,ICDFL,FILDT
S ICDFL=0
S EFFDT=$$ICD10DT()
S FILDT=$P(EFFDT,U,2),EFFDT=$P(EFFDT,U)
I EFFDT D
. D NOW^%DTC I FILDT S X=FILDT
. I EFFDT,X'<EFFDT S ICDFL=1
I '$D(^ROUTINE("ICDXCODE")) S ICDFL=0 ;ICD10 NOT INSTALLED AT SITE
;W !,"00 - Not Specified"
I 'ICDFL W !,"01 - International Classification of Diseases (ICD9)"
;OIT/CAS/RCS 06072012 Patch 45 - The following line is now uncommented
I ICDFL W !,"02 - International Classification of Diseases (ICD10)"
;W !,"03 - National Criteria Care Institute (NCCI)"
;W !,"04 - The Systematized Nomenclature of Human and"
;W !," Veterinary Medicine (SNOMED)"
;W !,"05 - Common Dental Terminology (CDT)"
;W !,"06 - Medi-Span Diagnosis Code (MSDC)"
;W !,"07 - American Psychiatric Association Diagnostic"
; !," Statistical Manual of Mental Disorders (DSM IV)"
;W !,"99 - Other"
Q
HELP424 ;EP - FM help code for file #9002313.491 - ABSP DIAGNOSIS
; field #424 - DIAGNOSIS CODE
;OIT/CAS/RCS 06072012 Patch 45 - Rewritten to allow ICD9 and ICD10 based on Implementation date
N RXI,RXVMED,VIS,POVS,PROB,EFFDT,X,ICDFL,FILDT
S RXI=+$P($G(^ABSP(9002313.491,DA(1),0)),U,3)
Q:'RXI
S RXVMED=+$$GETVMED(RXI)
S VIS=+$$GET1^DIQ(9000010.14,RXVMED,.03,"I")
; Build list of valid ICD9 codes that can be entered for
; diagnosis override from purpose of visit (V POV) and
; active problem list (PROBLEM).
; Get and display V POV list.
;OIT/CAS/RCS 06072012 Patch 45 - Refer to ICD9 and ICD10 appropriately
S ICDFL=0
S EFFDT=$$ICD10DT()
S FILDT=$P(EFFDT,U,2),EFFDT=$P(EFFDT,U)
I EFFDT D
. D NOW^%DTC I FILDT S X=FILDT
. I EFFDT,X'<EFFDT S ICDFL=1
I '$D(^ROUTINE("ICDXCODE")) S (EFFDT,ICDFL)=0 ;ICD10 NOT INSTALLED AT SITE
I ICDFL W !,"Valid ICD10 codes entered by provider:"
E W !,"Valid ICD9 codes entered by provider:"
D:VIS GETPOVS(VIS,EFFDT,ICDFL)
D DISPPOVS
; Get and display PROBLEM list.
D GETPROB(RXI,EFFDT,ICDFL)
D DISPPROB
Q
GETVMED(RXI) ;
N RXVMED
; First try to return the VMED for the first refill.
S RXVMED=+$$GET1^DIQ(52.1,"1,"_RXI_",",9999999.11,"I")
Q:RXVMED RXVMED
; Otherwise return VMED for the prescription
Q +$$GET1^DIQ(52,RXI,9999999.11,"I")
GETPOVS(VIS,EFFDT,X) ;#9000010.07 - V POV file
N PIEN,CODE,NARR,MES,IMPDT
I EFFDT D
. S IMPDT=$P($G(^ICDS(30,0)),"^",4) I 'IMPDT S X=0
. I X S IMPDT=IMPDT+1
. E S IMPDT=IMPDT-1
S PIEN=0
F S PIEN=$O(^AUPNVPOV("AD",VIS,PIEN)) Q:'PIEN D
. S CODE=$$GET1^DIQ(9000010.07,PIEN,.01)
. Q:CODE=""
. ;OIT/CAS/RCS 06072012 Patch 45 - CHECK FOR VALID ICD9/ICD10 CODE ON DATE
. I EFFDT S MES=$$ICDDATA^ICDXCODE("DIAG",CODE,IMPDT,"E") I $P(MES,"^")=-1 Q ;Invalid ICD code on date
. S NARR=$$GET1^DIQ(9000010.07,PIEN,.04)
. S POVS(CODE)=NARR
Q
DISPPOVS ;
N CODE,NARR
W !,"VISIT POV List:"
I '$D(POVS) D
. W !,?3,"No V POVS found."
I $D(POVS) D
. S CODE=""
. F S CODE=$O(POVS(CODE)) Q:CODE="" D
.. S NARR=$G(POVS(CODE))
.. W !,?3,CODE,?15,NARR
Q
GETPROB(RXI,EFFDT,X) ;#9000011 - PROBLEM file
N DFN,PIEN,CODE,NARR,MES,IMPDT
I EFFDT D
. S IMPDT=$P($G(^ICDS(30,0)),"^",4) I 'IMPDT S X=0
. I X S IMPDT=IMPDT+1
. E S IMPDT=IMPDT-1
S DFN=+$$GET1^DIQ(52,RXI,2,"I")
I $D(^AUPNPROB("AC",DFN)) D
. S PIEN=0
. F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D
.. S CODE=$$GET1^DIQ(9000011,PIEN,.01)
.. Q:CODE=""
.. ;OIT/CAS/RCS 06072012 Patch 45 - CHECK FOR VALID ICD9/ICD10 CODE ON DATE
.. I EFFDT S MES=$$ICDDATA^ICDXCODE("DIAG",CODE,IMPDT,"E") I $P(MES,"^")=-1 Q ;Invalid ICD code on date
.. S NARR=$$GET1^DIQ(9000011,PIEN,.05)
.. S PROB(CODE)=NARR
Q
DISPPROB ;
N CODE,NARR
W !,"PROBLEM List:"
I '$D(PROB) D
. W !,?3,"No PROBLEM entry found."
I $D(PROB) D
. S CODE=""
. F S CODE=$O(PROB(CODE)) Q:CODE="" D
.. S NARR=$G(PROB(CODE))
.. W !,?3,CODE,?15,NARR
Q
; Not sure which input transform to use yet, CHK424 or CHK424B.
; It was decided (Mike Danielson) to just check for valid entry in
; the ICD9 file (tag CHK424) to accommodate outside providers and
; the delay in getting the data entered. Keeping tag CHK424B just
; in case they change their minds.
CHK424(CODE) ;EP - FM input code for file #9002313.491 - ABSP DIAGNOSIS
; field #424 - DIAGNOSIS CODE
; This input transform just checks for a valid ICD9 code.
Q:$TR(CODE," ")="" 1 ;invalid ICD9 code, all spaces
N CODELKUP,CODEIEN,CODESTAT,MES,ICDFL,EFFDT,X,IMPDT,FILDT
S EFFDT=$$ICD10DT()
S FILDT=$P(EFFDT,U,2),EFFDT=$P(EFFDT,U)
I '$D(^ROUTINE("ICDXCODE")) S EFFDT=0 ;ICD10 NOT INSTALLED
I EFFDT D
. D NOW^%DTC I FILDT S X=FILDT
. I EFFDT,X'<EFFDT S ICDFL=1
. E S ICDFL=0
. S IMPDT=$P($G(^ICDS(30,0)),"^",4) I 'IMPDT S EFFDT=0 Q
. I ICDFL S IMPDT=IMPDT+1
. E S IMPDT=IMPDT-1
; Try lookup with code as is.
;OIT/CAS/RCS 06072012 Patch 45 - Add ICD9/ICD10 lookup
I EFFDT S MES=$$ICDDATA^ICDXCODE("DIAG",CODE,IMPDT,"E") I $P(MES,U,2)=CODE Q 0 ;valid ICD code for date
I 'EFFDT D Q:ICDCODE=CODE 0 ;valid ICD9 code
. S CODEIEN=$O(^ICD9("BA",CODE,""),-1)
. S ICDCODE=$P($$ICDDX^ICDCODE(CODEIEN),U,2)
; Try looking up with trailing space.
S CODELKUP=CODE_" "
;OIT/CAS/RCS 06072012 Patch 45 - Add ICD9/ICD10 lookup
I EFFDT S MES=$$ICDDATA^ICDXCODE("DIAG",CODELKUP,IMPDT,"E") I $P(MES,U,2)=CODE Q 0 ;valid ICD code for date
I 'EFFDT D Q:ICDCODE=CODE 0 ;valid ICD9 code
. S CODEIEN=$O(^ICD9("BA",CODELKUP,""),-1)
. S ICDCODE=$P($$ICDDX^ICDCODE(CODEIEN),U,2)
; Try looking up without trailing zeros and periods.
S CODELKUP=CODE
F D Q:$E(CODELKUP,$L(CODELKUP))'=0
. I $E(CODELKUP,$L(CODELKUP))=0 S CODELKUP=$E(CODELKUP,1,$L(CODELKUP)-1)
I $E(CODELKUP,$L(CODELKUP))="." S CODELKUP=$P(CODELKUP,".")
Q:CODELKUP="" 1 ;invalid ICD9 code, all zeros
;OIT/CAS/RCS 06072012 Patch 45 - Add ICD9/ICD10 lookup
I EFFDT S MES=$$ICDDATA^ICDXCODE("DIAG",CODELKUP,IMPDT,"E") I $P(MES,U,2)=CODE Q 0 ;valid ICD code for date
I 'EFFDT D Q:ICDCODE=CODE 0 ;valid ICD9 code
. S CODEIEN=$O(^ICD9("BA",CODELKUP,""),-1)
. S ICDCODE=$P($$ICDDX^ICDCODE(CODEIEN),U,2)
Q 1 ;invalid ICD9 code
;
CHK492 ;;OIT/CAS/RCS 06072012 Patch 45 - Field 492 default value, assumes todays date
;FROM SCREEN 25
N EFFDT,X,FILDT
S Y="01" ;DEFAULT
I '$D(^ROUTINE("ICDXCODE")) Q ;ICD10 NOT INSTALLED AT SITE
S EFFDT=$$ICD10DT()
S FILDT=$P(EFFDT,U,2),EFFDT=$P(EFFDT,U)
D NOW^%DTC I FILDT S X=FILDT
I EFFDT,X'<EFFDT S Y="02"
E S Y="01"
Q
CHK424B(X) ;EP - FM input code for file #9002313.491 - ABSP DIAGNOSIS
; field #424 - DIAGNOSIS CODE
; This input transform limits the valid ICD9 codes to those found
; in V POV and PROBLEM lists.
N RXI,RXVMED,VIS,POVS,PROB,CODE
S RXI=+$P($G(^ABSP(9002313.491,DA(1),0)),U,3)
Q:'RXI 0
S RXVMED=+$$GETVMED(RXI)
S VIS=+$$GET1^DIQ(9000010.14,RXVMED,.03,"I")
; Build list of valid ICD9 codes that can be entered for
; diagnosis override from purpose of visit (V POV) and
; active problem list (PROBLEM).
; Get V POV list.
D:VIS GETPOVS(VIS)
; Get PROBLEM list.
D GETPROB(RXI)
; Look for code match in V POV list
Q:$D(POVS(X)) 0 ;found in V POV list - valid code
; Look for code match in PROBLEM list
Q:$D(PROB(X)) 0 ;found in PROBLEM list - valid code
Q 1 ;not found in either list - invalid code
;
ICD10DT(X) ;OIT/CAS/RCS 06072012 Patch 45 - Find ICD10 Effective date to use for interface
;Return ICD10 Effective date and Fill/Refill date
N GENDT,RXI,RXR,Y,IEN59,INSIEN,INSDT,FDT
;Find POS General ICD10 effective date
S GENDT=$P($G(^ABSP(9002313.99,1,"ICD10")),U) I 'GENDT Q "0^0"
;Find Insurer ICD10 effective date
S RXI=$G(^TMP("DDS",$J,$P(DDS,U),"F9002313.512",DDSDAORG_","_DDSDAORG(1)_",",1.01,"D"))
S RXR=$G(^TMP("DDS",$J,$P(DDS,U),"F9002313.512",DDSDAORG_","_DDSDAORG(1)_",",1.02,"D"))
I 'RXI Q GENDT_"^0" ;Cannot find Rx
;Find Fill Date
I 'RXR S FDT=$P($G(^PSRX(RXI,2)),U,2) ;Fill date
E S FDT=$P($G(^PSRX(RXI,1,RXR,0)),U) ;Refill date
S Y=(RXR*10)+1,Y=$E("00000",1,5-$L(Y))_Y,IEN59=RXI_"."_Y
I $G(^ABSPT(IEN59,1))="" Q GENDT_"^"_FDT ;Cannot find Rx transaction
S INSIEN=$P($G(^ABSPT(IEN59,1)),U,6) I 'INSIEN Q GENDT
S INSDT=$P($G(^ABSPEI(INSIEN,"ICD10")),U) I 'INSDT Q GENDT_"^"_FDT
Q INSDT_"^"_FDT
ABSPOSII ; IHS/SD/RLT - DIAGNOSIS CODES form ; [ 06/21/2007 9:30 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**23,45,48**;JUN 21, 2007;Build 38
+2 ;
+3 QUIT
PREINIT ;EP - check for existing record
+1 ; This is the pre-init routine tied to ScreenMan form ABSP INPUT 1
+2 ; page 25 DIAGNOSIS CODE 5.1 ENTRY.
+3 ; This is used during the creation of the "NEW" claim from
+4 ; within POS (called from the "USER" screen) to capture
+5 ; DIAGNOSIS CODE values.
+6 ;
+7 ;OIT/CAS/RCS 06072012 Patch 45 - Use Diagnosis lookup for ICD9/ICD10 Implementation
+8 ;
+9 NEW RXI,RXR,DIAG,FDA,STRING
+10 ;
+11 ; get the prescription information
+12 ;RX IEN
SET RXI=$$GET^DDSVAL(DIE,.DA,1.01)
+13 ;RX Refill IEN
SET RXR=$$GET^DDSVAL(DIE,.DA,1.02)
+14 SET DIAG=""
+15 ;
+16 ;no pres - get out
IF $GET(RXI)=""
QUIT
+17 ;
+18 ;get DIAGNOSIS CODE pointer
SET DIAG=$$GETDIAG^ABSPOSO(RXI,RXR)
+19 ;
+20 ;DIANOSIS CODE exists
IF $GET(DIAG)'=""
Begin DoDot:1
+21 ;msg on scrn
SET STRING(1)="Will add diagnosis code from IEN RX "_RXI
+22 IF +RXR
SET STRING(1)=STRING(1)_" IEN Refill "_RXR
+23 ;displays what is happening
DO HLP^DDSUTL(.STRING)
+24 ;
End DoDot:1
+25 ;diagnosis code doesn't exist yet
IF $GET(DIAG)=""
Begin DoDot:1
+26 SET DIAG=$$NEW^ABSPOSD3
+27 SET STRING(1)="Will add new diagnosis code "_DIAG
+28 DO HLP^DDSUTL(.STRING)
End DoDot:1
+29 ;
+30 ; create empty entries for adding new data
+31 DO NEWSUB^ABSPOSD3(DIAG)
+32 ;
+33 ; now- update the input data file and the prescription
+34 ;POINTERS REMOVED FROM PRESCRIPTION FILE
+35 ;D UPDRX(RXI,RXR,DIAG)
+36 DO PUT^DDSVAL(DIE,.DA,1.15,DIAG,,"I")
+37 ;
+38 ; theres a chance they won't file the claim - hold on to the
+39 ; DIAG so we can clean up empty records if its not filed
+40 ;
+41 SET ^TMP("ABSPOSII",$JOB,DIAG)=RXI_"^"_RXR
+42 ;
+43 NEW VMED
+44 QUIT
+45 ;
CLNDIAG(IEN,ENTRY) ;EP from ABSPOSIZ
+1 ; clean up the DIAG file of empty entries
+2 ; and update the RX file when no override information
+3 ; was actually entered for the 5.1 DIAG segment.
+4 ; This routine called from ABSPOSIZ - subroutine FILE
+5 ;
+6 NEW DIAG,DATAREC
+7 ;
+8 SET DATAREC=$GET(^ABSP(9002313.51,IEN,2,ENTRY,1))
+9 ;
+10 SET DIAG=$PIECE(DATAREC,"^",12)
+11 ;just quit
IF DIAG=""
QUIT
+12 ;
+13 SET RXI=$PIECE(DATAREC,"^")
+14 SET RXR=$PIECE(DATAREC,"^",2)
+15 ;
+16 ;good data input?
SET DIAG=$$CHKDIAG^ABSPOSD3(DIAG)
+17 ;
+18 ;nothing input - delete it
IF $GET(DIAG)=""
Begin DoDot:1
+19 ;POINTERS REMOVED FROM PRESCRIPTION FILE
+20 ;D UPDRX(RXI,RXR,DIAG)
+21 ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
NEW FDA,ZERR
+22 SET FDA(9002313.51,ENTRY_","_IEN_",",1.15)=DIAG
+23 ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
DO FILE^DIE("","FDA","ZERR")
+24 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(ZERR)
DO LOG^ABSPOSL2("CLNDIAG^ABSPOSII",.ZERR)
End DoDot:1
+25 ;
+26 ;update DIAG count after cleaning
DO DIAGCNT(DIAG)
+27 ;
+28 QUIT
+29 ;
UPDRX(RXI,RXR,DIAG) ;POINTERS REMOVED FROM PRESCRIPTION FILE
+1 ; update the prescription with the DIAG 5.1 information
+2 ; and the ABSP Data Input file with the appropriate value
+3 ;
+4 ; N FDA,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
+5 ;
+6 ; DIAG set within POSTINIT
+7 ; RXR - rx refill IEN
+8 ; RXI - rx IEN
+9 ; DIAG - NCPDP 5.1 DIAG segment pointer
+10 ;
+11 ;I '+$G(RXR) D ;NOT a refill
+12 ;. S FDA(52,RXI_",",9999999.17)=DIAG
+13 ;. D FILE^DIE("","FDA","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
+14 ;. I $D(ZERR) D LOG^ABSPOSL2("UPDRX+13^ABSPOSII",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
+15 ;
+16 ;I +$G(RXR) D ;refill
+17 ;. S FDA(52.1,RXR_","_RXI_",",9999999.17)=DIAG
+18 ;. D FILE^DIE("","FDA","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
+19 ;. I $D(ZERR) D LOG^ABSPOSL2("UPDRX+18^ABSPOSII",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
+20 ;
+21 QUIT
+22 ;
NOCLM ;EP - called from ABSPOSI when the claims are NOT filed - we
+1 ; still must clean up the empty records if they called upon
+2 ; the DIAGNOSIS CODES entry
+3 ;
+4 NEW DIAGIEN,CLNDIAG,DIAGREC,RXI,RXR
+5 ;
+6 SET DIAGIEN=0
+7 FOR
SET DIAGIEN=$ORDER(^TMP("ABSPOSII",$JOB,DIAGIEN))
IF DIAGIEN=""
QUIT
Begin DoDot:1
+8 SET DIAGREC=$GET(^TMP("ABSPOSII",$JOB,DIAGIEN))
+9 ;internal RX number
SET RXI=$PIECE(DIAGREC,"^")
+10 ;refill number
SET RXR=$PIECE(DIAGREC,"^",2)
+11 SET CLNDIAG=$$CHKDIAG^ABSPOSD3(DIAGIEN)
+12 ;POINTERS REMOVED FROM PRESCRIPTION FILE
+13 ;D:$G(CLNDIAG)="" UPDRX(RXI,RXR,CLNDIAG)
End DoDot:1
+14 ;
+15 QUIT
DIAGCNT(DIAG) ;
+1 ;
+2 IF DIAG=""
QUIT
+3 ;
+4 NEW DIAGIEN,DIAGCNT,DIAGCNTR
+5 ;
+6 SET (DIAGIEN,DIAGCNT,DIAGCNTR)=0
+7 FOR
SET DIAGIEN=$ORDER(^ABSP(9002313.491,DIAG,1,DIAGIEN))
IF '+DIAGIEN
QUIT
Begin DoDot:1
+8 SET DIAGCNT=DIAGCNT+1
+9 SET DIAGCNTR=$PIECE($GET(^ABSP(9002313.491,DIAG,1,DIAGIEN,0)),U)
+10 IF DIAGCNTR'=DIAGCNT
Begin DoDot:2
+11 DO CNTFIX(9002313.4911,DIAG,DIAGIEN,DIAGCNT)
End DoDot:2
End DoDot:1
+12 ;
+13 SET $PIECE(^ABSP(9002313.491,DIAG,0),U,5)=DIAGCNT
+14 QUIT
CNTFIX(FILE,REC,SUB,CNT) ;
+1 ;
+2 NEW FDA
+3 SET FDA(FILE,SUB_","_REC_",",.01)=CNT
CNTFILE ;
+1 DO FILE^DIE("","FDA","MSG")
+2 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("CNTFILE^ABSPOSII",.MSG)
+3 IF $DATA(MSG)
IF $$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"CNTFILE",$TEXT(+0))
GOTO CNTFILE
+4 ;
+5 QUIT
HELP492 ;EP - Help code for file #9002313.491 - ABSP DIAGNOSIS
+1 ; field #492 - DIAGNOSIS CODE QUALIFIER
+2 NEW EFFDT,X,ICDFL,FILDT
+3 SET ICDFL=0
+4 SET EFFDT=$$ICD10DT()
+5 SET FILDT=$PIECE(EFFDT,U,2)
SET EFFDT=$PIECE(EFFDT,U)
+6 IF EFFDT
Begin DoDot:1
+7 DO NOW^%DTC
IF FILDT
SET X=FILDT
+8 IF EFFDT
IF X'<EFFDT
SET ICDFL=1
End DoDot:1
+9 ;ICD10 NOT INSTALLED AT SITE
IF '$DATA(^ROUTINE("ICDXCODE"))
SET ICDFL=0
+10 ;W !,"00 - Not Specified"
+11 IF 'ICDFL
WRITE !,"01 - International Classification of Diseases (ICD9)"
+12 ;OIT/CAS/RCS 06072012 Patch 45 - The following line is now uncommented
+13 IF ICDFL
WRITE !,"02 - International Classification of Diseases (ICD10)"
+14 ;W !,"03 - National Criteria Care Institute (NCCI)"
+15 ;W !,"04 - The Systematized Nomenclature of Human and"
+16 ;W !," Veterinary Medicine (SNOMED)"
+17 ;W !,"05 - Common Dental Terminology (CDT)"
+18 ;W !,"06 - Medi-Span Diagnosis Code (MSDC)"
+19 ;W !,"07 - American Psychiatric Association Diagnostic"
+20 ; !," Statistical Manual of Mental Disorders (DSM IV)"
+21 ;W !,"99 - Other"
+22 QUIT
HELP424 ;EP - FM help code for file #9002313.491 - ABSP DIAGNOSIS
+1 ; field #424 - DIAGNOSIS CODE
+2 ;OIT/CAS/RCS 06072012 Patch 45 - Rewritten to allow ICD9 and ICD10 based on Implementation date
+3 NEW RXI,RXVMED,VIS,POVS,PROB,EFFDT,X,ICDFL,FILDT
+4 SET RXI=+$PIECE($GET(^ABSP(9002313.491,DA(1),0)),U,3)
+5 IF 'RXI
QUIT
+6 SET RXVMED=+$$GETVMED(RXI)
+7 SET VIS=+$$GET1^DIQ(9000010.14,RXVMED,.03,"I")
+8 ; Build list of valid ICD9 codes that can be entered for
+9 ; diagnosis override from purpose of visit (V POV) and
+10 ; active problem list (PROBLEM).
+11 ; Get and display V POV list.
+12 ;OIT/CAS/RCS 06072012 Patch 45 - Refer to ICD9 and ICD10 appropriately
+13 SET ICDFL=0
+14 SET EFFDT=$$ICD10DT()
+15 SET FILDT=$PIECE(EFFDT,U,2)
SET EFFDT=$PIECE(EFFDT,U)
+16 IF EFFDT
Begin DoDot:1
+17 DO NOW^%DTC
IF FILDT
SET X=FILDT
+18 IF EFFDT
IF X'<EFFDT
SET ICDFL=1
End DoDot:1
+19 ;ICD10 NOT INSTALLED AT SITE
IF '$DATA(^ROUTINE("ICDXCODE"))
SET (EFFDT,ICDFL)=0
+20 IF ICDFL
WRITE !,"Valid ICD10 codes entered by provider:"
+21 IF '$TEST
WRITE !,"Valid ICD9 codes entered by provider:"
+22 IF VIS
DO GETPOVS(VIS,EFFDT,ICDFL)
+23 DO DISPPOVS
+24 ; Get and display PROBLEM list.
+25 DO GETPROB(RXI,EFFDT,ICDFL)
+26 DO DISPPROB
+27 QUIT
GETVMED(RXI) ;
+1 NEW RXVMED
+2 ; First try to return the VMED for the first refill.
+3 SET RXVMED=+$$GET1^DIQ(52.1,"1,"_RXI_",",9999999.11,"I")
+4 IF RXVMED
QUIT RXVMED
+5 ; Otherwise return VMED for the prescription
+6 QUIT +$$GET1^DIQ(52,RXI,9999999.11,"I")
GETPOVS(VIS,EFFDT,X) ;#9000010.07 - V POV file
+1 NEW PIEN,CODE,NARR,MES,IMPDT
+2 IF EFFDT
Begin DoDot:1
+3 SET IMPDT=$PIECE($GET(^ICDS(30,0)),"^",4)
IF 'IMPDT
SET X=0
+4 IF X
SET IMPDT=IMPDT+1
+5 IF '$TEST
SET IMPDT=IMPDT-1
End DoDot:1
+6 SET PIEN=0
+7 FOR
SET PIEN=$ORDER(^AUPNVPOV("AD",VIS,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+8 SET CODE=$$GET1^DIQ(9000010.07,PIEN,.01)
+9 IF CODE=""
QUIT
+10 ;OIT/CAS/RCS 06072012 Patch 45 - CHECK FOR VALID ICD9/ICD10 CODE ON DATE
+11 ;Invalid ICD code on date
IF EFFDT
SET MES=$$ICDDATA^ICDXCODE("DIAG",CODE,IMPDT,"E")
IF $PIECE(MES,"^")=-1
QUIT
+12 SET NARR=$$GET1^DIQ(9000010.07,PIEN,.04)
+13 SET POVS(CODE)=NARR
End DoDot:1
+14 QUIT
DISPPOVS ;
+1 NEW CODE,NARR
+2 WRITE !,"VISIT POV List:"
+3 IF '$DATA(POVS)
Begin DoDot:1
+4 WRITE !,?3,"No V POVS found."
End DoDot:1
+5 IF $DATA(POVS)
Begin DoDot:1
+6 SET CODE=""
+7 FOR
SET CODE=$ORDER(POVS(CODE))
IF CODE=""
QUIT
Begin DoDot:2
+8 SET NARR=$GET(POVS(CODE))
+9 WRITE !,?3,CODE,?15,NARR
End DoDot:2
End DoDot:1
+10 QUIT
GETPROB(RXI,EFFDT,X) ;#9000011 - PROBLEM file
+1 NEW DFN,PIEN,CODE,NARR,MES,IMPDT
+2 IF EFFDT
Begin DoDot:1
+3 SET IMPDT=$PIECE($GET(^ICDS(30,0)),"^",4)
IF 'IMPDT
SET X=0
+4 IF X
SET IMPDT=IMPDT+1
+5 IF '$TEST
SET IMPDT=IMPDT-1
End DoDot:1
+6 SET DFN=+$$GET1^DIQ(52,RXI,2,"I")
+7 IF $DATA(^AUPNPROB("AC",DFN))
Begin DoDot:1
+8 SET PIEN=0
+9 FOR
SET PIEN=$ORDER(^AUPNPROB("AC",DFN,PIEN))
IF 'PIEN
QUIT
Begin DoDot:2
+10 SET CODE=$$GET1^DIQ(9000011,PIEN,.01)
+11 IF CODE=""
QUIT
+12 ;OIT/CAS/RCS 06072012 Patch 45 - CHECK FOR VALID ICD9/ICD10 CODE ON DATE
+13 ;Invalid ICD code on date
IF EFFDT
SET MES=$$ICDDATA^ICDXCODE("DIAG",CODE,IMPDT,"E")
IF $PIECE(MES,"^")=-1
QUIT
+14 SET NARR=$$GET1^DIQ(9000011,PIEN,.05)
+15 SET PROB(CODE)=NARR
End DoDot:2
End DoDot:1
+16 QUIT
DISPPROB ;
+1 NEW CODE,NARR
+2 WRITE !,"PROBLEM List:"
+3 IF '$DATA(PROB)
Begin DoDot:1
+4 WRITE !,?3,"No PROBLEM entry found."
End DoDot:1
+5 IF $DATA(PROB)
Begin DoDot:1
+6 SET CODE=""
+7 FOR
SET CODE=$ORDER(PROB(CODE))
IF CODE=""
QUIT
Begin DoDot:2
+8 SET NARR=$GET(PROB(CODE))
+9 WRITE !,?3,CODE,?15,NARR
End DoDot:2
End DoDot:1
+10 QUIT
+11 ; Not sure which input transform to use yet, CHK424 or CHK424B.
+12 ; It was decided (Mike Danielson) to just check for valid entry in
+13 ; the ICD9 file (tag CHK424) to accommodate outside providers and
+14 ; the delay in getting the data entered. Keeping tag CHK424B just
+15 ; in case they change their minds.
CHK424(CODE) ;EP - FM input code for file #9002313.491 - ABSP DIAGNOSIS
+1 ; field #424 - DIAGNOSIS CODE
+2 ; This input transform just checks for a valid ICD9 code.
+3 ;invalid ICD9 code, all spaces
IF $TRANSLATE(CODE," ")=""
QUIT 1
+4 NEW CODELKUP,CODEIEN,CODESTAT,MES,ICDFL,EFFDT,X,IMPDT,FILDT
+5 SET EFFDT=$$ICD10DT()
+6 SET FILDT=$PIECE(EFFDT,U,2)
SET EFFDT=$PIECE(EFFDT,U)
+7 ;ICD10 NOT INSTALLED
IF '$DATA(^ROUTINE("ICDXCODE"))
SET EFFDT=0
+8 IF EFFDT
Begin DoDot:1
+9 DO NOW^%DTC
IF FILDT
SET X=FILDT
+10 IF EFFDT
IF X'<EFFDT
SET ICDFL=1
+11 IF '$TEST
SET ICDFL=0
+12 SET IMPDT=$PIECE($GET(^ICDS(30,0)),"^",4)
IF 'IMPDT
SET EFFDT=0
QUIT
+13 IF ICDFL
SET IMPDT=IMPDT+1
+14 IF '$TEST
SET IMPDT=IMPDT-1
End DoDot:1
+15 ; Try lookup with code as is.
+16 ;OIT/CAS/RCS 06072012 Patch 45 - Add ICD9/ICD10 lookup
+17 ;valid ICD code for date
IF EFFDT
SET MES=$$ICDDATA^ICDXCODE("DIAG",CODE,IMPDT,"E")
IF $PIECE(MES,U,2)=CODE
QUIT 0
+18 ;valid ICD9 code
IF 'EFFDT
Begin DoDot:1
+19 SET CODEIEN=$ORDER(^ICD9("BA",CODE,""),-1)
+20 SET ICDCODE=$PIECE($$ICDDX^ICDCODE(CODEIEN),U,2)
End DoDot:1
IF ICDCODE=CODE
QUIT 0
+21 ; Try looking up with trailing space.
+22 SET CODELKUP=CODE_" "
+23 ;OIT/CAS/RCS 06072012 Patch 45 - Add ICD9/ICD10 lookup
+24 ;valid ICD code for date
IF EFFDT
SET MES=$$ICDDATA^ICDXCODE("DIAG",CODELKUP,IMPDT,"E")
IF $PIECE(MES,U,2)=CODE
QUIT 0
+25 ;valid ICD9 code
IF 'EFFDT
Begin DoDot:1
+26 SET CODEIEN=$ORDER(^ICD9("BA",CODELKUP,""),-1)
+27 SET ICDCODE=$PIECE($$ICDDX^ICDCODE(CODEIEN),U,2)
End DoDot:1
IF ICDCODE=CODE
QUIT 0
+28 ; Try looking up without trailing zeros and periods.
+29 SET CODELKUP=CODE
+30 FOR
Begin DoDot:1
+31 IF $EXTRACT(CODELKUP,$LENGTH(CODELKUP))=0
SET CODELKUP=$EXTRACT(CODELKUP,1,$LENGTH(CODELKUP)-1)
End DoDot:1
IF $EXTRACT(CODELKUP,$LENGTH(CODELKUP))'=0
QUIT
+32 IF $EXTRACT(CODELKUP,$LENGTH(CODELKUP))="."
SET CODELKUP=$PIECE(CODELKUP,".")
+33 ;invalid ICD9 code, all zeros
IF CODELKUP=""
QUIT 1
+34 ;OIT/CAS/RCS 06072012 Patch 45 - Add ICD9/ICD10 lookup
+35 ;valid ICD code for date
IF EFFDT
SET MES=$$ICDDATA^ICDXCODE("DIAG",CODELKUP,IMPDT,"E")
IF $PIECE(MES,U,2)=CODE
QUIT 0
+36 ;valid ICD9 code
IF 'EFFDT
Begin DoDot:1
+37 SET CODEIEN=$ORDER(^ICD9("BA",CODELKUP,""),-1)
+38 SET ICDCODE=$PIECE($$ICDDX^ICDCODE(CODEIEN),U,2)
End DoDot:1
IF ICDCODE=CODE
QUIT 0
+39 ;invalid ICD9 code
QUIT 1
+40 ;
CHK492 ;;OIT/CAS/RCS 06072012 Patch 45 - Field 492 default value, assumes todays date
+1 ;FROM SCREEN 25
+2 NEW EFFDT,X,FILDT
+3 ;DEFAULT
SET Y="01"
+4 ;ICD10 NOT INSTALLED AT SITE
IF '$DATA(^ROUTINE("ICDXCODE"))
QUIT
+5 SET EFFDT=$$ICD10DT()
+6 SET FILDT=$PIECE(EFFDT,U,2)
SET EFFDT=$PIECE(EFFDT,U)
+7 DO NOW^%DTC
IF FILDT
SET X=FILDT
+8 IF EFFDT
IF X'<EFFDT
SET Y="02"
+9 IF '$TEST
SET Y="01"
+10 QUIT
CHK424B(X) ;EP - FM input code for file #9002313.491 - ABSP DIAGNOSIS
+1 ; field #424 - DIAGNOSIS CODE
+2 ; This input transform limits the valid ICD9 codes to those found
+3 ; in V POV and PROBLEM lists.
+4 NEW RXI,RXVMED,VIS,POVS,PROB,CODE
+5 SET RXI=+$PIECE($GET(^ABSP(9002313.491,DA(1),0)),U,3)
+6 IF 'RXI
QUIT 0
+7 SET RXVMED=+$$GETVMED(RXI)
+8 SET VIS=+$$GET1^DIQ(9000010.14,RXVMED,.03,"I")
+9 ; Build list of valid ICD9 codes that can be entered for
+10 ; diagnosis override from purpose of visit (V POV) and
+11 ; active problem list (PROBLEM).
+12 ; Get V POV list.
+13 IF VIS
DO GETPOVS(VIS)
+14 ; Get PROBLEM list.
+15 DO GETPROB(RXI)
+16 ; Look for code match in V POV list
+17 ;found in V POV list - valid code
IF $DATA(POVS(X))
QUIT 0
+18 ; Look for code match in PROBLEM list
+19 ;found in PROBLEM list - valid code
IF $DATA(PROB(X))
QUIT 0
+20 ;not found in either list - invalid code
QUIT 1
+21 ;
ICD10DT(X) ;OIT/CAS/RCS 06072012 Patch 45 - Find ICD10 Effective date to use for interface
+1 ;Return ICD10 Effective date and Fill/Refill date
+2 NEW GENDT,RXI,RXR,Y,IEN59,INSIEN,INSDT,FDT
+3 ;Find POS General ICD10 effective date
+4 SET GENDT=$PIECE($GET(^ABSP(9002313.99,1,"ICD10")),U)
IF 'GENDT
QUIT "0^0"
+5 ;Find Insurer ICD10 effective date
+6 SET RXI=$GET(^TMP("DDS",$JOB,$PIECE(DDS,U),"F9002313.512",DDSDAORG_","_DDSDAORG(1)_",",1.01,"D"))
+7 SET RXR=$GET(^TMP("DDS",$JOB,$PIECE(DDS,U),"F9002313.512",DDSDAORG_","_DDSDAORG(1)_",",1.02,"D"))
+8 ;Cannot find Rx
IF 'RXI
QUIT GENDT_"^0"
+9 ;Find Fill Date
+10 ;Fill date
IF 'RXR
SET FDT=$PIECE($GET(^PSRX(RXI,2)),U,2)
+11 ;Refill date
IF '$TEST
SET FDT=$PIECE($GET(^PSRX(RXI,1,RXR,0)),U)
+12 SET Y=(RXR*10)+1
SET Y=$EXTRACT("00000",1,5-$LENGTH(Y))_Y
SET IEN59=RXI_"."_Y
+13 ;Cannot find Rx transaction
IF $GET(^ABSPT(IEN59,1))=""
QUIT GENDT_"^"_FDT
+14 SET INSIEN=$PIECE($GET(^ABSPT(IEN59,1)),U,6)
IF 'INSIEN
QUIT GENDT
+15 SET INSDT=$PIECE($GET(^ABSPEI(INSIEN,"ICD10")),U)
IF 'INSDT
QUIT GENDT_"^"_FDT
+16 QUIT INSDT_"^"_FDT
