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

ABSPOSI2.m

Go to the documentation of this file. 
  1. ABSPOSI2 ; IHS/FCS/DRS - support for the NDC/HCPCS/CPT field ;    [ 09/12/2002  10:10 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,40,44**;JUN 21, 2001;Build 38
  1.  Q
  1. VALID ; this is what's called from the field's Data Validation field 
  1.  I ^TMP("DDS",$J,$P(DDS,U),"F9002313.512",DDSDA,.02,"D")="" S DDSERROR=299 Q   ;IHS/OIT/CNI/RAN patch 40 avoid undefined in user screen when RX is blank
  1.  N Z S Z=$$VALIDATE(X)
  1.  ;OIT/CAS/RCS 09252012 - Patch 44, Quit if error reason is set
  1.  I Z<0,$D(DDSERROR) Q
  1.  ;S ^TMP($J,$T(+0),"VALIDATED")=Z
  1.  I Z<0 D  Q
  1.  . D IMPOSS^ABSPOSUE("P","TI","VALIDATE should have set DDSERROR","or Z is incorrectly <0","VALID",$T(+0))
  1.  I X'=Z D
  1.  . S (X,DDSEXT)=Z
  1.  Q
  1.  ; A onetime problem:  if you type an abbreviation, say PO
  1.  ;  it expands to POSTAGE,  the pop-up page appears,
  1.  ;  and when the pop-up is done, it goes back to PO.
  1.  ; Field's post action PUT^DDSVAL(DIE,.DA,.03,X) works.
  1.  ;  That's to make sure the expanded version gets stored.
  1.  ;
  1. VALIDATE(X)         ;  validate input and return transformed value 
  1.  ; returns <0 and sets DDSERROR if error
  1.  ; If successful, you could get:
  1.  ;   1. NDC number ?10N or ?11N
  1.  ;   2. NDC number with hyphens still in it
  1.  ;   3. The word POSTAGE
  1.  ;   4. "CPT "_CPTCODE   (requires uniqueness!!!)
  1.  N RET K DDSERROR
  1.  ;
  1.  ; First, some pre-processing:
  1. VAL0 ;
  1.  I X?1"++3"10.11N2E D  ; Abbot Labs bar codes are "really funky"
  1.  . S X=$E(X,4,$L(X)-2)
  1.  I X?12N,$E(X)=0 S X=$E(X,2,12) ; chop leading zero off a 12-digit NDC?
  1.  ;
  1.  ; Now the If/Else list:  K RET if there was a problem
  1. VAL1 I 0 ;
  1.  E  I X?10N D  ; Lookup in AWP MED-TRANSACTION
  1.  . S RET=$$NDC10^ABSPOS9(X)
  1.  . I RET="" D  S DDSERROR=201
  1.  . . D HLP^DDSUTL("We couldn't figure out the 10-digit NDC #"_X)
  1.  . . D HLP^DDSUTL("Retype it in 5-4-1 or 4-4-2 or 5-3-2 format.")
  1.  . E  D PRINTNAM(X)
  1.  E  I X?11N D  ; Lookup in AWP MED-TRANSACTION
  1.  . S RET=$$NDC11^ABSPOS9(X)
  1.  . I RET="" D
  1.  . . D HLP^DDSUTL("We couldn't find the 11-digit NDC #"_X)
  1.  . . D HLP^DDSUTL("but we will process it anyhow.")
  1.  . . S RET=X
  1.  . E  D PRINTNAM(X)
  1.  E  I $L(X,"-")=3 D
  1.  . I X?4N1"-"4N1"-"2N S RET=X ; NDC formats with "-"
  1.  . E  I X?5N1"-"3N1"-"2N S RET=X ; are always accepted
  1.  . E  I X?5N1"-"4N1"-"1N S RET=X
  1.  . E  I X?5N1"-"4N1"-"2N S RET=X
  1.  . E  D  K RET S DDSERROR=205
  1.  . . D HLP^DDSUTL("4-4-2, 5-3-2, 5-4-1, and 5-4-2 are the recognized formats.")
  1.  E  I $E("POSTAGE",1,$L(X))=$$UPPER(X) D
  1.  . S RET="POSTAGE"
  1.  E  I $E("FIND",1,$L(X))=$$UPPER(X) D
  1.  . ; not implemented - would do a lookup of CPT code
  1.  E  D  ; supply items, CPT codes, HCPCS codes, etc.
  1.  . ; maybe special codes in here?
  1.  . I X?1"CPT ".E S X=$P(X,"CPT ",2)
  1.  . S RET=$$CPT(X) I RET]"" S RET="CPT "_X Q
  1.  . K RET S DDSERROR=299
  1.  I $D(DDSERROR) D
  1.  . D HLP^DDSUTL("Did not recognize "_X)
  1.  . K RET
  1.  Q $S($D(RET):RET,1:-1)
  1. CPT(X) ; Lookup CPT code.  If found, return CPTIEN.
  1.  Q $$LOOKUP("^ABSCPT(9002300,",X)
  1.  ;
  1. EFFECTS ;
  1.  ; Force an update of pricing when you enter page 7, by wiping out
  1.  ;  any unit price that might already be stored there.
  1.  I $$GET^DDSVAL(9002313.51,DA(1),1.03),$$GET^DDSVAL(DIE,.DA,5.02)]"" D
  1.  . D PUT^DDSVAL(DIE,.DA,5.02,"")
  1.  ;
  1.  ; Input of a CPT code has many implications:
  1.  I X?1"CPT "1E.E D
  1.  . ;D MSGWAIT("In EFFECTS^"_$T(+0)_" with X="_X)
  1.  . N CPTCODE S CPTCODE=$P(X,"CPT ",2)
  1.  . N CPTIEN S CPTIEN=$$LOOKUP("^ABSCPT(9002300,",CPTCODE)
  1.  . ;D MSGWAIT("$$LOOKUP yields CPTIEN="_CPTIEN)
  1.  . N C0 S C0=^ABSCPT(9002300,CPTIEN,0)
  1.  . N CPTDESC S CPTDESC=$P(C0,U,2)
  1.  . I CPTDESC="" S CPTDESC=$P(C0,U,3)
  1.  . N PRICE S PRICE=$P(C0,U,5)
  1.  . N VISITIEN S VISITIEN=$$GET^DDSVAL(DIE,.DA,1.06,"I")
  1.  . N VCN S VCN=$P($G(^AUPNVSIT(VISITIEN,"VCN")),U)
  1.  . I VCN="" S VCN="V`"_VISITIEN
  1.  . D PUT^DDSVAL(DIE,.DA,.02,VCN)
  1.  . D PUT^DDSVAL(DIE,.DA,.05,CPTDESC)
  1.  . D PUT^DDSVAL(DIE,.DA,.06,$$MMMDD($P(^AUPNVSIT(VISITIEN,0),U)))
  1.  . D PUT^DDSVAL(DIE,.DA,1.01,"") ;RXI
  1.  . D PUT^DDSVAL(DIE,.DA,1.02,"") ;RXR
  1.  . D PUT^DDSVAL(DIE,.DA,1.05,"") ;AWPMED
  1.  . D PUT^DDSVAL(DIE,.DA,1.08,CPTIEN,,"I")
  1.  . D PUT^DDSVAL(DIE,.DA,5.01,1)
  1.  . D PUT^DDSVAL(DIE,.DA,5.02,PRICE)
  1.  . D PUT^DDSVAL(DIE,.DA,5.04,0) ; no dispense fee?
  1.  . D PUT^DDSVAL(DIE,.DA,5.06,"ABSCPT",,"I") ; source of price
  1.  . ;IHS/OIT/SCR 11/20/08
  1.  . D PUT^DDSVAL(DIE,.DA,5.07,0) ; no incentive amount
  1.  . D RECALC1^ABSPOSI7
  1.  Q
  1. MMMDD(Y) Q $$MMMDD^ABSPOSI1(Y)
  1. MSGWAIT(X)         D MSGWAIT^ABSPOSI1(X) Q
  1. LOOKUP(DICX,X)          ; general lookup, given file root DIC ; 
  1.  ; returns IEN if success, false if failure
  1.  N DIC,DTIME,DLAYGO,DINUM,Y,DTOUT,DUOUT
  1.  S DIC=DICX,DIC(0)="MNSX"
  1.  S DIC("S")="I Y<100000" ; disallow input of drugs as CPT codes
  1.  D ^DIC
  1.  Q $S(Y>0:+Y,1:"")
  1. STOREAWP ; not implemented - we don't have a readily-available AWP pointer
  1.  Q
  1. PRINTNAM(X)        ; print name as found in AWP MED-TRANSACTION file
  1.  ; Print it in the help area, as the name from the drug file is
  1.  ; usually more complete and informative
  1.  N NAME S NAME=$$NAME^ABSPOS9(X)
  1.  D HLP^DDSUTL(X_" is "_NAME)
  1.  Q
  1. HELP ;
  1.  N AR,N S N=0
  1.  D HELP1("Enter the NDC number")
  1.  D HELP1("or a CPT or HCPCS code")
  1.  D HLP^DDSUTL(.AR)
  1.  Q
  1. HELP1(X) S N=N+1,AR(N)=X Q
  1. ASKPRE() Q $$GET^DDSVAL(9002313.51,DA(1),1.02)
  1. ASKINS() Q $$GET^DDSVAL(9002313.51,DA(1),1.01) ; actually,should check for exact value
  1. ASKPRI() Q $$GET^DDSVAL(9002313.51,DA(1),1.03)
  1. ASKDATE() Q $$GET^DDSVAL(9002313.51,DA(1),1.04)
  1. BRANCH ;
  1.  I $$ASKPRE!$$ASKINS!$$ASKPRI!$$ASKDATE S DDSSTACK=3
  1.  QUIT
  1.  ; DUPLICATE LABEL:
  1.  ;MSGWAIT(X)         N AR S AR(1)=X
  1.  ; ,AR(2)="$$EOP" 
  1.  ;D HLP^DDSUTL(.AR)
  1.  ;D HLP^DDSUTL("$$EOP")
  1.  ;Q
  1. UPPER(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")