PSNAPIS ;BIR/DMA-APIs for NDF ; 27 Jan 2010 7:44 AM
;;4.0;NATIONAL DRUG FILE;**2,3,47,70,169,108,262,296,448,492**; 30 Oct 98;Build 27
;
;Reference to ^PSDRUG supported by DBIA #2192
;Reference to ^PS(50.606 supported by DBIA #2174
;Reference to $$PROD0^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to ^XTMP supported by DBIA #4770
;Referenct to ^PSS50 supported by DBIA #4483
;
PSA(NDC,LIST) ;ENTRY FOR DRUG ACCOUNTABILITY
N Y,PN,PN1,P50,J
S Y=$Q(^PSNDF(50.67,"NDC",NDC)) I $QS(Y,3)'=NDC Q 0
S Y=^PSNDF(50.67,$QS(Y,4),0),Y=$P(Y,"^",6),PN=$P(^PSNDF(50.68,Y,0),"^"),PN1=$E(PN,1,30)
S P50=0,J=0 F S P50=$O(^PSDRUG("VAPN",PN1,P50)) Q:'P50 I $P(^PSDRUG(P50,"ND"),"^",2)=PN S LIST(P50)=$P(^PSDRUG(P50,0),"^"),J=J+1
Q J
;
PSJING(DA1,K,LIST) ;ENTRY FOR INGREDIENTS
N X,CT
;DA1 IS SUPERFLUOUS, BUT WE LEAVE IN FOR COMPATABILITY
I 'K!('$D(^PSNDF(50.68,+K))) Q 0
S DA=0 F CT=0:1 S DA=$O(^PSNDF(50.68,K,2,DA)) Q:'DA S X=^(DA,0),LIST(+X)=+X_"^"_$P(^PS(50.416,+X,0),"^")_"^"_$P(X,"^",2)_"^" S:$P(X,"^",3)]"" LIST(+X)=LIST(+X)_$P($G(^PS(50.607,$P(X,"^",3),0)),"^")
Q CT
;
PSJDF(DA,K) ;GET DOSE FORM
N X,DF
;AGAIN DA IS SUPERFLUOUS
I 'K!('$D(^PSNDF(50.68,+K))) Q 0
S X=$P(^PSNDF(50.68,K,0),"^",3),DF=$P($G(^PS(50.606,X,0)),"^")
Q X_"^"_DF
;
PSJST(DA,K) ;ENTRY FOR STRENGTH
I 'K!('$D(^PSNDF(50.68,K))) Q 0
Q 1_"^"_$P(^PSNDF(50.68,K,0),"^",4)
;
CLASS(CL) ;ENTRY FOR OE/RR TO GET CLASS $D
I CL']"" Q 0
Q $D(^PS(50.605,"C",CL))>0
;
DRUG(DA) ;ENTRY FOR OE/RR TO GET DRUG $D
I DA']"" Q 0
Q $D(^PSNDF(50.6,"B",DA))!$D(^PSNDF(50.67,"T",DA))
;
PROD0(P1,P2) ;GET INFO IN THE FORM OF THE OLD 0 PRODUCT NODE
N A,B
;P1 IS SUPERFLUOUS
I P2']"" Q ""
S A=$G(^PSNDF(50.68,P2,0)),B=$G(^(1))
Q $P(A,"^")_"^"_$P(A,"^",3,5)_"^^^"_$P(B,"^",5,6)
;
PROD2(P1,P2) ;GET OLD 2 NODE
;P1 STILL SUPERFLUOUS
I P2']"" Q ""
Q $P($G(^PSNDF(50.68,P2,1)),"^",1,3)_"^"_$P($G(^PSNDF(50.64,+$P(^PSNDF(50.68,P2,1),"^",4),0)),"^")
;
DCLASS(DA,K) ;GET CLASS FOR PRODUCT
I K']"" Q ""
S X=+$P($G(^PSNDF(50.68,+K,3)),"^"),Y=$P($G(^PS(50.605,X,0)),"^",2)
Q X_"^"_Y
;
DCLCODE(DA,K) ;RETURN VA CLASS CODE
I K']"" Q ""
S X=+$P($G(^PSNDF(50.68,+K,3)),"^"),X=$P($G(^PS(50.605,X,0)),"^")
Q X
;
;DA IS SUPERFLUOUS
VAGN(DA) ;GET VA GENERIC NAME
I 'DA!'$D(^PSNDF(50.6,+DA,0)) Q 0
Q $P(^PSNDF(50.6,+DA,0),"^")
;
FORMI(DA,K) ;GET FORMULARY INDICATOR FOR VA PRODUCT
;DA IS SUPERFLUOUS
;1 if yes, 0 if no, null if not entered
Q $P($G(^PSNDF(50.68,+K,5)),"^")
;
FORMR(DA,K) ;GET EXISTENCE OF FORMULARY RESTRICTIONS
;DA IS SUPERFLUOUS
Q $O(^PSNDF(50.68,+K,6,0))]""
;
DFSU(DA,K) ;RETURN DOSE FORM, STRENGTH, AND UNITS FOR PDM AND CPRS
N U1,UN
I 'K!('$D(^PSNDF(50.68,+K,0))) Q 0
S U1=+$P(^PSNDF(50.68,+K,0),"^",5),UN=$P($G(^PS(50.607,U1,0)),"^")
Q $$PSJDF(DA,K)_"^"_$$PSJST(DA,K)_"^"_U1_"^"_UN
;
VAP(DA,LIST) ;GIVEN GENERIC RETURN ARRAY LIST(IEN)=IEN^PRODUCT^DF PTR^DOSE FOMR^CLIEN^CLASS^INACTIVE^TIER
N PR,J,X,DAT
I 'DA!'$D(^PSNDF(50.6,+DA)) Q 0
S PR=0,J=0 F S PR=$O(^PSNDF(50.6,"APRO",DA,PR)) Q:'PR S X=^PSNDF(50.68,PR,0),DAT=$P($G(^(7)),"^",3) D
.S LIST(PR)=PR_"^"_$P(X,"^")_"^"_$P(X,"^",3)_"^"_$P($G(^PS(50.606,+$P(X,"^",3),0)),"^")_"^"_$P(^PSNDF(50.68,PR,3),"^")_"^"_$P($G(^PS(50.605,+$P(^PSNDF(50.68,PR,3),"^"),0)),"^"),J=J+1 I DAT,(DAT<DT) S LIST(PR)=LIST(PR)_"^I"
. N CPDATE,PSSTIER D NOW^%DTC S CPDATE=$P(%,".")
. S PSSTIER=$$CPTIER^PSNAPIS(PR,CPDATE,"",1),$P(LIST(PR),"^",8)="Tier "_$P(PSSTIER,"^",1) K CPDATE,%,X,PSSTIER
Q J
;
PSPT(DA,K,LIST) ;GIVEN PRODUCT K RETURN LIST(INE1^IEN2)=IEN1^PSIZE^IEN1^PTYPE
N NDC,J,PT,PS
;DA SUPERFLUOUS
I 'K!'$D(^PSNDF(50.68,+K)) Q 0
S NDC=0 F J=0:1 S NDC=$O(^PSNDF(50.68,"ANDC",K,NDC)) Q:'NDC S X=^PSNDF(50.67,NDC,0),PS=$P(X,"^",8),PT=$P(X,"^",9),LIST(PS_"^"_PT)=PS_"^"_$P($G(^PS(50.609,PS,0)),"^")_"^"_PT_"^"_$P($G(^PS(50.608,PT,0)),"^")
Q J
;
DSS(DA,K,DATE) ;RETURN DSS FEEDER KEY
;NEW STYLE IF DATE IS MISSING OR NOT LESS THAN 199810
;OLD STYLE OTHERWISE
S DATE=$G(DATE,999999)
I DATE'<199810 Q $S($D(^PSNDF(50.68,+K)):$$RJ^XLFSTR(K,5,0),1:"00000")
I $D(^PSNDF(50.6,+DA)),$D(^PSNDF(50.68,+K,7)) Q $$RJ^XLFSTR(DA,4,0)_$$RJ^XLFSTR($P(^PSNDF(50.68,+K,7),"^",9),3,0)
Q "0000000"
;
CPRS(DA,K) ;CALL FOR CPRS
N CL,X,DF,ST,UN
;RETURNS X=DOSE FORM^CLASS^STRENGTH^UNITS
I '$D(^PSNDF(50.68,+K)) Q 0
S CL=$P($G(^PS(50.605,+$P(^PSNDF(50.68,K,3),"^"),0)),"^")
S X=^PSNDF(50.68,K,0),DF=+$P(X,"^",3),ST=$P(X,"^",4),UN=+$P(X,"^",5)
Q $P($G(^PS(50.606,DF,0)),"^")_"^"_CL_"^"_ST_"^"_$P($G(^PS(50.607,UN,0)),"^")
;
CIRN(NDC,LIST) ;CALL FOR CIRN
N DA,X,A
I NDC["-" S NDC=$$RJ^XLFSTR($P(NDC,"-"),6,0)_$$RJ^XLFSTR($P(NDC,"-",2),4,0)_$$RJ^XLFSTR($P(NDC,"-",3),2,0)
K LIST S LIST="000000000000" F J=1:1:7 S LIST(J)=""
S DA=$O(^PSNDF(50.67,"NDC",NDC,0)) Q:'DA S X=^PSNDF(50.67,DA,0),LIST(7)=$P(X,"^",2)_"^"_$P(X,"^",4,6)_"^",A=0 F S A=$O(^PSNDF(50.67,DA,1,A)) Q:'A S LIST(7)=LIST(7)_^(A,0)_" "
S LIST(6)=$P(X,"^",9),LIST(5)=$P(X,"^",8),A=$P(X,"^",6),X=^PSNDF(50.68,A,0)
S LIST(2)=$P(X,"^",3)_"^^"_$P(^PSNDF(50.68,A,3),"^"),LIST(3)=$P(X,"^",4),LIST(4)=$P(X,"^",5)
S LIST(0)=$P(X,"^",2),LIST(1)=^PSNDF(50.6,$P(X,"^",2),0),LIST=NDC
F J=1:1:7 I LIST(J)="NO DATA" S LIST(J)=""
Q
;
B() ;RETURNS THE GLOBAL ROOT OF THE "B" CROSSREFERENCE IN NDF
Q "^PSNDF(50.6,""B"")"
;
T() ;RETURNS THE GLOBAL ROOT OF THE "T" CROSSREFERENCE IN NDF
Q "^PSNDF(50.67,""T"")"
;
TTOG(TRADE,LIST) ;RETURNS LIST(IEN)=IEN_"^"GENERIC FOR EVERY ENTRY IN 50.6 WHICH MATCHES THE TRADE NAME
I TRADE="" Q 0
N X,CT
I '$O(^PSNDF(50.67,"T",TRADE,0)) Q 0
S (X,CT)=0 F S X=$O(^PSNDF(50.67,"T",TRADE,X)) Q:'X S Y=$P(^PSNDF(50.67,X,0),"^",6),Y=$P(^PSNDF(50.68,Y,0),"^",2) I '$D(LIST(Y)) S LIST(Y)=Y_"^"_$P(^PSNDF(50.6,Y,0),"^"),CT=CT+1
Q CT
;
CLIST(DA,LIST) ;RETURNS LIST(IEN)=IEN IN 50.605^CLASS CODE
;FOR EVERY CLASS IN PSNDF(50.6,DA)
I 'DA Q 0
I '$D(^PSNDF(50.6,+DA)) Q 0
N K,CT S (K,CT)=0 F S K=$O(^PSNDF(50.6,"APRO",DA,K)) Q:'K S IEN=$P(^PSNDF(50.68,K,3),"^") I '$D(LIST(IEN)) S LIST(IEN)=IEN_"^"_$P(^PS(50.605,IEN,0),"^"),CT=CT+1
Q CT
;
TGTOG(NAME) ;GIVEN NAME TRY TO FIND IT IN T OR B CROSS REFERENCE AND RETURN IEN
N X
I NAME="" Q 0
S X=$O(^PSNDF(50.6,"B",NAME,0)) I X Q X
I '$O(^PSNDF(50.67,"T",NAME,0)) Q 0
S X=$O(^PSNDF(50.67,"T",NAME,0)),X=$P(^PSNDF(50.67,X,0),"^",6),X=$P(^PSNDF(50.68,X,0),"^",2) Q X
;
TGTOG2(NAME,LIST) ;PARTIAL LOOKUP ON T OR B
I NAME="" Q
N NAM,X,Y,CT
S CT=0
S NAM=$E(NAME,1,$L(NAME)-1)_$C($A($E(NAME,$L(NAME)))-1)_"z" F S NAM=$O(^PSNDF(50.6,"B",NAM)),X=0 Q:NAM'[NAME F S X=$O(^PSNDF(50.6,"B",NAM,X)) Q:'X S LIST(X)=X_"^"_$P(^PSNDF(50.6,X,0),"^"),CT=CT+1
S NAM=$E(NAME,1,$L(NAME)-1)_$C($A($E(NAME,$L(NAME)))-1)_"z" F S NAM=$O(^PSNDF(50.67,"T",NAM)),X=0 Q:NAM'[NAME F S X=$O(^PSNDF(50.67,"T",NAM,X)) Q:'X S Y=$P(^PSNDF(50.67,X,0),"^",6),Y=$P(^PSNDF(50.68,Y,0),"^",2) D
.I '$D(LIST(Y)) S LIST(Y)=Y_"^"_$P(^PSNDF(50.6,Y,0),"^"),CT=CT+1
Q CT
;
CIRN2(P1,P3,LIST) ;RETURN LIST OF NDCS FOR A PRODUCT
I 'P3 Q 0
I '$D(^PSNDF(50.68,+P3)) Q 0
N D,N,J
S N=0
F J=0:1 S N=$O(^PSNDF(50.68,"ANDC",P3,N)) Q:'N S LIST(J)=$P(^PSNDF(50.67,N,0),"^",2)
Q J
;
CLASS2(IEN) ;RETURNS FIRST 2 PIECES OF ZERO NODE OF 50.605
Q $P($G(^PS(50.605,+IEN,0)),"^",1,2)
;
CMOP(CODE) ;CODE = 5 CHARACTER CMOP CODE RETURNS PRODUCT NAME
I CODE="" Q ""
I '$O(^PSNDF(50.68,"C",CODE,0)) Q ""
Q $P(^PSNDF(50.68,+$O(^PSNDF(50.68,"C",CODE,0)),0),"^")
;
FORMRX(DA,K,LIST) ;RETURN X=1 FOR RESTRICTIONS, 0 FOR NO
;RETURNS LIST=WORD PROCESSING FIELD FOR RESTRICTIONS
;
I '$O(^PSNDF(50.68,+K,6,0)) Q 0
M LIST=^PSNDF(50.68,+K,6) Q 1
;
DDIEX(DA,K) ;RETURN X=1 FOR EXCLUDE DDI CHECK, 0 FOR CONTINUE DDI CHECK
;
I '$G(^PSNDF(50.68,+K,8)) Q 0
I $G(^PSNDF(50.68,+K,8)) Q 1
;
OVRIDE(PSNPOV1,PSNPOV3) ;Return Override Dose Form Exclusion
I '$G(PSNPOV3) Q ""
Q $P($G(^PSNDF(50.68,+PSNPOV3,9)),"^")
;
FDAMG(IEN) ;RETURN URL FOR MED GUIDE OR NULL
Q $P($G(^PSNDF(50.68,IEN,"MG")),"^")
;
POSDOS(IEN) ; Return Possible Dosage Auto-Creation Related fields
; Input: IEN - VA Product (#50.68) IEN
;Output: Possible Dosage Creation field (separated by "^")
; 1. CREATE DEFAULT POSSIBLE DOSAGE (Y/N) - Field #40
; 2. POSSIBLE DOSAGES TO CREATE (N/O/B) - Field #41
; 3. PACKAGE (I/O/IO) - Field #42
;
Q $G(^PSNDF(50.68,IEN,"DOS"))
;
INTRAN(SCR) ; input transform lookup for fields that store NDC codes
; Input: SCR - (optional) M code for value of DIC("S") - If SCR is not
; defined, all active entries will be returned
;
; Output: The variable X will be returned if input is valid. If no valid
; input is available, X will be not be returned.
;
N D,DIC,Y
S DIC("S")="I $P(^(0),U,7)=""""!($P(^(0),U,7)>DT)"
I $G(SCR)'="" S DIC("S")=SCR
S DIC="^PSNDF(50.67,",DIC(0)="EMQZ"
S D="A" D IX^DIC
I +$G(Y)>0 S X=$P(Y(0),"^",2)
I $G(Y)=-1 K X
Q
;
DRGCLS(IEN) ; return class and parent class for NDC
; Input: IEN - (required) internal entry number of NDC in file 50.67
;
; Output: Drug Class code^Parent Class
N PSNP,PSNDC,PSNCLS
S PSNCLS=""
S PSNP=$P($G(^PSNDF(50.67,IEN,0)),"^",6) Q:'PSNP PSNCLS
S PSNDC=$P($G(^PSNDF(50.68,PSNP,3)),"^") Q:'PSNDC PSNCLS
S PSNCLS=$$GET1^DIQ(50.605,PSNDC,.01)_"^"_$$GET1^DIQ(50.605,PSNDC,2)
Q PSNCLS
;
QLIST(SCR) ; executable help ("?" or "??") for fields that store NDC codes
; Input: SCR - (optional) M code for value of DIC("S") - If SCR is not
; defined, all active entries will be returned
N D,DIC,DO,X
S DIC("S")="I $P(^(0),U,7)=""""!($P(^(0),U,7)>DT)"
I $G(SCR)'="" S DIC("S")=SCR
S X="?",DIC="^PSNDF(50.67,",DIC(0)="EQS",D="NDC"
D IX^DIC
Q
;
CPTIER(VAPIEN,DATE,PSNDRIEN,PSNCINQS) ; RETURN COPAY TIER INFORMATION (FMCT)
;Input: VAPIEN - VA Product (#50.68) IEN
; DATE - Date to be verified for Copay Tier
; PSNDRIEN - Drug file (#50) IEN.
; PSNCINQS - 1 if an inquiry screen, null if called by IB
; The VAPIEN and/or the PSNDRIEN may be passed; however, the PSNDRIEN takes precedence.
; If the PSNDRIEN variable isn't defined, the VAPIEN IEN will be processed.
;
;Output: Tier^Effective Date^End Date
;
;*************************************************************************************************
;** Copay Tier Business Rules: (DO NOT REMOVE)
; - Pharmacy Product System - National (PPS-N) is used to define copay tier information.
; - A check for the DEA special Handling code for the drug is an additional check made
; in Pharmacy to determine if a drug is exempt from copay. The copay exempt DEA codes
; are: I = Investigational Drug, N = Nutritional Supplement and S for Supply Item.
;
; Copay Tier determination criteria:
; 1. For NDF and PDM display screens (i.e. PSNACT, PSNLOOK, PSSDEE, PSS LOOK), this API
; will return null if the copay tier is not defined or will return the defined copay tier
; for the given date. If the drug is not matched to NDF, null is returned. If the tier is
; null, the selection of drug or product screens will not display the Tier field; however,
; the body of the display will show the Tier and effective date as null.
;
; 2. If the DEA Special Handling Code is exempt from copay and regardless of the copay
; tier value, this API will return zero. OP will not call IB for billing. The DEA Special
; Handling Code overrides the nationally defined copay tier.
;
; 3. The product is matched to NDF:
; a. If the copay tier is 1, 2, or 3 and the DEA code is NOT exempt from copay, this
; API will return the defined copay tier. OP will call IB to charge copay. Copay
; will be charged based on the tier defined.
; b. If the copay tier is 0 (zero), this API will return 0 (zero). OP will not call
; IB to charge copay.
; c. If no copay tier is defined and the product is NOT exempt from copay, this API
; will return null. OP will call IB to charge copay and IB will default the copay
; tier to 2.
;
; 4. The product is not matched to NDF:
; a. If the DEA special handling code is NOT exempt from copay, this API will return
; null. OP will call IB to charge copay. IB will default to copay tier 2 then
; charge copay.
;
; 5. The copay tier does not have a rate defined in IB, this API will return the defined copay
; tier. OP will call IB to charge copay and IB will default to tier 2 and charge copay.
;*************************************************************************************************
;
N FLG,I,II,CPTIER,EFFDT,ENDDT,TIER,RETTIER,RETURN,DEASH,DEA,DEAFLG,PSOTIERE
S:'$G(PSNCINQS) PSNCINQS=""
S RETURN=""
;SQA TESTING ONLY - S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY"
D NOW^%DTC N PSOTIERE
S PSOTIERE=1 ;use copay tiers - new
I $P(%,".")<3170227 S PSOTIERE=0 ;legacy billing - old
I $G(^XTMP("PSOTIEREFTST",0)) S PSOTIERE=1 ;for SQA testing only - bill with copay tiers - new
I 'PSOTIERE S RETTIER="" Q RETTIER
;***** end for regression test
;
I $G(PSNDRIEN) S RETURN=$$CPTIER3(RETURN,DATE,PSNDRIEN) Q RETURN
I $G(VAPIEN) S RETURN=$$CPTIER2(RETURN,DATE,VAPIEN) Q RETURN
Q ""
;
CPTIER2(RETURN,DATE,VAPIEN) ;
I '$O(^PSNDF(50.68,VAPIEN,10,0)) Q ""
S PSOTIERE=1 ;use copay tiers - new
S (FLG,II)=0,RETTIER=""
F S II=$O(^PSNDF(50.68,VAPIEN,10,II)) Q:'II S CPTIER=$G(^PSNDF(50.68,VAPIEN,10,II,0)) I CPTIER'="" D
.S TIER=$P(CPTIER,"^"),EFFDT=$P(CPTIER,"^",2),ENDDT=$P(CPTIER,"^",3)
.I $G(EFFDT)&($G(ENDDT)),(DATE'<EFFDT&(DATE'>ENDDT)) S FLG=1,RETTIER=CPTIER
.I $G(EFFDT)&('$G(ENDDT)),DATE'<EFFDT S FLG=1,RETTIER=CPTIER
Q RETTIER
;
CPTIER3(RETURN,DATE,PSNDRIEN) ;
;
K ^TMP($J,"PSNAPIS")
D NDF^PSS50(PSNDRIEN,,,,,"PSNAPIS")
S (DEAFLG,DEASH)="",DEASH=$$GET1^DIQ(50,PSNDRIEN,3)
I DEASH'="" F I=1:1:$L(DEASH) S DEA="",DEA=$E(DEASH,I) D
. I (",I,S,N,")[(","_DEA_",") S DEAFLG=1
S:$D(^TMP($J,"PSNAPIS",PSNDRIEN,22)) VAPIEN=$P(^TMP($J,"PSNAPIS",PSNDRIEN,22),"^")
;not matched to NDF
;I VAPIEN="" S RETURN=$S($G(PSNCINQS):"",'$G(PSNCINQS):0,1:"") Q RETURN
I VAPIEN="" S RETURN="" Q RETURN
;matched to NDF
S RETURN=$$CPTIER2(RETURN,DATE,VAPIEN)
I +RETURN="" D Q RETURN ;MATCHED
. I $G(PSNCINQS) S RETURN="" Q
. S RETURN=0
;DEA special handling code is exempt from copay
I $G(DEAFLG)&('$D(RETURN)) D Q RETURN
. I $G(PSNCINQS) S RETURN="" Q
. S RETURN=0
K ^TMP($J,"PSNAPIS")
;otherwise return defined copay tier info
Q RETURN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNAPIS 14826 printed Dec 13, 2024@02:23:40 Page 2
PSNAPIS ;BIR/DMA-APIs for NDF ; 27 Jan 2010 7:44 AM
+1 ;;4.0;NATIONAL DRUG FILE;**2,3,47,70,169,108,262,296,448,492**; 30 Oct 98;Build 27
+2 ;
+3 ;Reference to ^PSDRUG supported by DBIA #2192
+4 ;Reference to ^PS(50.606 supported by DBIA #2174
+5 ;Reference to $$PROD0^PSNAPIS(P1,P3) supported by DBIA #2531
+6 ;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531
+7 ;Reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
+8 ;Reference to ^XTMP supported by DBIA #4770
+9 ;Referenct to ^PSS50 supported by DBIA #4483
+10 ;
PSA(NDC,LIST) ;ENTRY FOR DRUG ACCOUNTABILITY
+1 NEW Y,PN,PN1,P50,J
+2 SET Y=$QUERY(^PSNDF(50.67,"NDC",NDC))
IF $QSUBSCRIPT(Y,3)'=NDC
QUIT 0
+3 SET Y=^PSNDF(50.67,$QSUBSCRIPT(Y,4),0)
SET Y=$PIECE(Y,"^",6)
SET PN=$PIECE(^PSNDF(50.68,Y,0),"^")
SET PN1=$EXTRACT(PN,1,30)
+4 SET P50=0
SET J=0
FOR
SET P50=$ORDER(^PSDRUG("VAPN",PN1,P50))
if 'P50
QUIT
IF $PIECE(^PSDRUG(P50,"ND"),"^",2)=PN
SET LIST(P50)=$PIECE(^PSDRUG(P50,0),"^")
SET J=J+1
+5 QUIT J
+6 ;
PSJING(DA1,K,LIST) ;ENTRY FOR INGREDIENTS
+1 NEW X,CT
+2 ;DA1 IS SUPERFLUOUS, BUT WE LEAVE IN FOR COMPATABILITY
+3 IF 'K!('$DATA(^PSNDF(50.68,+K)))
QUIT 0
+4 SET DA=0
FOR CT=0:1
SET DA=$ORDER(^PSNDF(50.68,K,2,DA))
if 'DA
QUIT
SET X=^(DA,0)
SET LIST(+X)=+X_"^"_$PIECE(^PS(50.416,+X,0),"^")_"^"_$PIECE(X,"^",2)_"^"
if $PIECE(X,"^",3)]""
SET LIST(+X)=LIST(+X)_$PIECE($GET(^PS(50.607,$PIECE(X,"^",3),0)),"^")
+5 QUIT CT
+6 ;
PSJDF(DA,K) ;GET DOSE FORM
+1 NEW X,DF
+2 ;AGAIN DA IS SUPERFLUOUS
+3 IF 'K!('$DATA(^PSNDF(50.68,+K)))
QUIT 0
+4 SET X=$PIECE(^PSNDF(50.68,K,0),"^",3)
SET DF=$PIECE($GET(^PS(50.606,X,0)),"^")
+5 QUIT X_"^"_DF
+6 ;
PSJST(DA,K) ;ENTRY FOR STRENGTH
+1 IF 'K!('$DATA(^PSNDF(50.68,K)))
QUIT 0
+2 QUIT 1_"^"_$PIECE(^PSNDF(50.68,K,0),"^",4)
+3 ;
CLASS(CL) ;ENTRY FOR OE/RR TO GET CLASS $D
+1 IF CL']""
QUIT 0
+2 QUIT $DATA(^PS(50.605,"C",CL))>0
+3 ;
DRUG(DA) ;ENTRY FOR OE/RR TO GET DRUG $D
+1 IF DA']""
QUIT 0
+2 QUIT $DATA(^PSNDF(50.6,"B",DA))!$DATA(^PSNDF(50.67,"T",DA))
+3 ;
PROD0(P1,P2) ;GET INFO IN THE FORM OF THE OLD 0 PRODUCT NODE
+1 NEW A,B
+2 ;P1 IS SUPERFLUOUS
+3 IF P2']""
QUIT ""
+4 SET A=$GET(^PSNDF(50.68,P2,0))
SET B=$GET(^(1))
+5 QUIT $PIECE(A,"^")_"^"_$PIECE(A,"^",3,5)_"^^^"_$PIECE(B,"^",5,6)
+6 ;
PROD2(P1,P2) ;GET OLD 2 NODE
+1 ;P1 STILL SUPERFLUOUS
+2 IF P2']""
QUIT ""
+3 QUIT $PIECE($GET(^PSNDF(50.68,P2,1)),"^",1,3)_"^"_$PIECE($GET(^PSNDF(50.64,+$PIECE(^PSNDF(50.68,P2,1),"^",4),0)),"^")
+4 ;
DCLASS(DA,K) ;GET CLASS FOR PRODUCT
+1 IF K']""
QUIT ""
+2 SET X=+$PIECE($GET(^PSNDF(50.68,+K,3)),"^")
SET Y=$PIECE($GET(^PS(50.605,X,0)),"^",2)
+3 QUIT X_"^"_Y
+4 ;
DCLCODE(DA,K) ;RETURN VA CLASS CODE
+1 IF K']""
QUIT ""
+2 SET X=+$PIECE($GET(^PSNDF(50.68,+K,3)),"^")
SET X=$PIECE($GET(^PS(50.605,X,0)),"^")
+3 QUIT X
+4 ;
+5 ;DA IS SUPERFLUOUS
VAGN(DA) ;GET VA GENERIC NAME
+1 IF 'DA!'$DATA(^PSNDF(50.6,+DA,0))
QUIT 0
+2 QUIT $PIECE(^PSNDF(50.6,+DA,0),"^")
+3 ;
FORMI(DA,K) ;GET FORMULARY INDICATOR FOR VA PRODUCT
+1 ;DA IS SUPERFLUOUS
+2 ;1 if yes, 0 if no, null if not entered
+3 QUIT $PIECE($GET(^PSNDF(50.68,+K,5)),"^")
+4 ;
FORMR(DA,K) ;GET EXISTENCE OF FORMULARY RESTRICTIONS
+1 ;DA IS SUPERFLUOUS
+2 QUIT $ORDER(^PSNDF(50.68,+K,6,0))]""
+3 ;
DFSU(DA,K) ;RETURN DOSE FORM, STRENGTH, AND UNITS FOR PDM AND CPRS
+1 NEW U1,UN
+2 IF 'K!('$DATA(^PSNDF(50.68,+K,0)))
QUIT 0
+3 SET U1=+$PIECE(^PSNDF(50.68,+K,0),"^",5)
SET UN=$PIECE($GET(^PS(50.607,U1,0)),"^")
+4 QUIT $$PSJDF(DA,K)_"^"_$$PSJST(DA,K)_"^"_U1_"^"_UN
+5 ;
VAP(DA,LIST) ;GIVEN GENERIC RETURN ARRAY LIST(IEN)=IEN^PRODUCT^DF PTR^DOSE FOMR^CLIEN^CLASS^INACTIVE^TIER
+1 NEW PR,J,X,DAT
+2 IF 'DA!'$DATA(^PSNDF(50.6,+DA))
QUIT 0
+3 SET PR=0
SET J=0
FOR
SET PR=$ORDER(^PSNDF(50.6,"APRO",DA,PR))
if 'PR
QUIT
SET X=^PSNDF(50.68,PR,0)
SET DAT=$PIECE($GET(^(7)),"^",3)
Begin DoDot:1
+4 SET LIST(PR)=PR_"^"_$PIECE(X,"^")_"^"_$PIECE(X,"^",3)_"^"_$PIECE($GET(^PS(50.606,+$PIECE(X,"^",3),0)),"^")_"^"_$PIECE(^PSNDF(50.68,PR,3),"^")_"^"_$PIECE($GET(^PS(50.605,+$PIECE(^PSNDF(50.68,PR,3),"^"),0)),"^")
SET J=J+1
IF DAT
IF (DAT<DT)
SET LIST(PR)=LIST(PR)_"^I"
+5 NEW CPDATE,PSSTIER
DO NOW^%DTC
SET CPDATE=$PIECE(%,".")
+6 SET PSSTIER=$$CPTIER^PSNAPIS(PR,CPDATE,"",1)
SET $PIECE(LIST(PR),"^",8)="Tier "_$PIECE(PSSTIER,"^",1)
KILL CPDATE,%,X,PSSTIER
End DoDot:1
+7 QUIT J
+8 ;
PSPT(DA,K,LIST) ;GIVEN PRODUCT K RETURN LIST(INE1^IEN2)=IEN1^PSIZE^IEN1^PTYPE
+1 NEW NDC,J,PT,PS
+2 ;DA SUPERFLUOUS
+3 IF 'K!'$DATA(^PSNDF(50.68,+K))
QUIT 0
+4 SET NDC=0
FOR J=0:1
SET NDC=$ORDER(^PSNDF(50.68,"ANDC",K,NDC))
if 'NDC
QUIT
SET X=^PSNDF(50.67,NDC,0)
SET PS=$PIECE(X,"^",8)
SET PT=$PIECE(X,"^",9)
SET LIST(PS_"^"_PT)=PS_"^"_$PIECE($GET(^PS(50.609,PS,0)),"^")_"^"_PT_"^"_$PIECE($GET(^PS(50.608,PT,0)),"^")
+5 QUIT J
+6 ;
DSS(DA,K,DATE) ;RETURN DSS FEEDER KEY
+1 ;NEW STYLE IF DATE IS MISSING OR NOT LESS THAN 199810
+2 ;OLD STYLE OTHERWISE
+3 SET DATE=$GET(DATE,999999)
+4 IF DATE'<199810
QUIT $SELECT($DATA(^PSNDF(50.68,+K)):$$RJ^XLFSTR(K,5,0),1:"00000")
+5 IF $DATA(^PSNDF(50.6,+DA))
IF $DATA(^PSNDF(50.68,+K,7))
QUIT $$RJ^XLFSTR(DA,4,0)_$$RJ^XLFSTR($PIECE(^PSNDF(50.68,+K,7),"^",9),3,0)
+6 QUIT "0000000"
+7 ;
CPRS(DA,K) ;CALL FOR CPRS
+1 NEW CL,X,DF,ST,UN
+2 ;RETURNS X=DOSE FORM^CLASS^STRENGTH^UNITS
+3 IF '$DATA(^PSNDF(50.68,+K))
QUIT 0
+4 SET CL=$PIECE($GET(^PS(50.605,+$PIECE(^PSNDF(50.68,K,3),"^"),0)),"^")
+5 SET X=^PSNDF(50.68,K,0)
SET DF=+$PIECE(X,"^",3)
SET ST=$PIECE(X,"^",4)
SET UN=+$PIECE(X,"^",5)
+6 QUIT $PIECE($GET(^PS(50.606,DF,0)),"^")_"^"_CL_"^"_ST_"^"_$PIECE($GET(^PS(50.607,UN,0)),"^")
+7 ;
CIRN(NDC,LIST) ;CALL FOR CIRN
+1 NEW DA,X,A
+2 IF NDC["-"
SET NDC=$$RJ^XLFSTR($PIECE(NDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(NDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(NDC,"-",3),2,0)
+3 KILL LIST
SET LIST="000000000000"
FOR J=1:1:7
SET LIST(J)=""
+4 SET DA=$ORDER(^PSNDF(50.67,"NDC",NDC,0))
if 'DA
QUIT
SET X=^PSNDF(50.67,DA,0)
SET LIST(7)=$PIECE(X,"^",2)_"^"_$PIECE(X,"^",4,6)_"^"
SET A=0
FOR
SET A=$ORDER(^PSNDF(50.67,DA,1,A))
if 'A
QUIT
SET LIST(7)=LIST(7)_^(A,0)_" "
+5 SET LIST(6)=$PIECE(X,"^",9)
SET LIST(5)=$PIECE(X,"^",8)
SET A=$PIECE(X,"^",6)
SET X=^PSNDF(50.68,A,0)
+6 SET LIST(2)=$PIECE(X,"^",3)_"^^"_$PIECE(^PSNDF(50.68,A,3),"^")
SET LIST(3)=$PIECE(X,"^",4)
SET LIST(4)=$PIECE(X,"^",5)
+7 SET LIST(0)=$PIECE(X,"^",2)
SET LIST(1)=^PSNDF(50.6,$PIECE(X,"^",2),0)
SET LIST=NDC
+8 FOR J=1:1:7
IF LIST(J)="NO DATA"
SET LIST(J)=""
+9 QUIT
+10 ;
B() ;RETURNS THE GLOBAL ROOT OF THE "B" CROSSREFERENCE IN NDF
+1 QUIT "^PSNDF(50.6,""B"")"
+2 ;
T() ;RETURNS THE GLOBAL ROOT OF THE "T" CROSSREFERENCE IN NDF
+1 QUIT "^PSNDF(50.67,""T"")"
+2 ;
TTOG(TRADE,LIST) ;RETURNS LIST(IEN)=IEN_"^"GENERIC FOR EVERY ENTRY IN 50.6 WHICH MATCHES THE TRADE NAME
+1 IF TRADE=""
QUIT 0
+2 NEW X,CT
+3 IF '$ORDER(^PSNDF(50.67,"T",TRADE,0))
QUIT 0
+4 SET (X,CT)=0
FOR
SET X=$ORDER(^PSNDF(50.67,"T",TRADE,X))
if 'X
QUIT
SET Y=$PIECE(^PSNDF(50.67,X,0),"^",6)
SET Y=$PIECE(^PSNDF(50.68,Y,0),"^",2)
IF '$DATA(LIST(Y))
SET LIST(Y)=Y_"^"_$PIECE(^PSNDF(50.6,Y,0),"^")
SET CT=CT+1
+5 QUIT CT
+6 ;
CLIST(DA,LIST) ;RETURNS LIST(IEN)=IEN IN 50.605^CLASS CODE
+1 ;FOR EVERY CLASS IN PSNDF(50.6,DA)
+2 IF 'DA
QUIT 0
+3 IF '$DATA(^PSNDF(50.6,+DA))
QUIT 0
+4 NEW K,CT
SET (K,CT)=0
FOR
SET K=$ORDER(^PSNDF(50.6,"APRO",DA,K))
if 'K
QUIT
SET IEN=$PIECE(^PSNDF(50.68,K,3),"^")
IF '$DATA(LIST(IEN))
SET LIST(IEN)=IEN_"^"_$PIECE(^PS(50.605,IEN,0),"^")
SET CT=CT+1
+5 QUIT CT
+6 ;
TGTOG(NAME) ;GIVEN NAME TRY TO FIND IT IN T OR B CROSS REFERENCE AND RETURN IEN
+1 NEW X
+2 IF NAME=""
QUIT 0
+3 SET X=$ORDER(^PSNDF(50.6,"B",NAME,0))
IF X
QUIT X
+4 IF '$ORDER(^PSNDF(50.67,"T",NAME,0))
QUIT 0
+5 SET X=$ORDER(^PSNDF(50.67,"T",NAME,0))
SET X=$PIECE(^PSNDF(50.67,X,0),"^",6)
SET X=$PIECE(^PSNDF(50.68,X,0),"^",2)
QUIT X
+6 ;
TGTOG2(NAME,LIST) ;PARTIAL LOOKUP ON T OR B
+1 IF NAME=""
QUIT
+2 NEW NAM,X,Y,CT
+3 SET CT=0
+4 SET NAM=$EXTRACT(NAME,1,$LENGTH(NAME)-1)_$CHAR($ASCII($EXTRACT(NAME,$LENGTH(NAME)))-1)_"z"
FOR
SET NAM=$ORDER(^PSNDF(50.6,"B",NAM))
SET X=0
if NAM'[NAME
QUIT
FOR
SET X=$ORDER(^PSNDF(50.6,"B",NAM,X))
if 'X
QUIT
SET LIST(X)=X_"^"_$PIECE(^PSNDF(50.6,X,0),"^")
SET CT=CT+1
+5 SET NAM=$EXTRACT(NAME,1,$LENGTH(NAME)-1)_$CHAR($ASCII($EXTRACT(NAME,$LENGTH(NAME)))-1)_"z"
FOR
SET NAM=$ORDER(^PSNDF(50.67,"T",NAM))
SET X=0
if NAM'[NAME
QUIT
FOR
SET X=$ORDER(^PSNDF(50.67,"T",NAM,X))
if 'X
QUIT
SET Y=$PIECE(^PSNDF(50.67,X,0),"^",6)
SET Y=$PIECE(^PSNDF(50.68,Y,0),"^",2)
Begin DoDot:1
+6 IF '$DATA(LIST(Y))
SET LIST(Y)=Y_"^"_$PIECE(^PSNDF(50.6,Y,0),"^")
SET CT=CT+1
End DoDot:1
+7 QUIT CT
+8 ;
CIRN2(P1,P3,LIST) ;RETURN LIST OF NDCS FOR A PRODUCT
+1 IF 'P3
QUIT 0
+2 IF '$DATA(^PSNDF(50.68,+P3))
QUIT 0
+3 NEW D,N,J
+4 SET N=0
+5 FOR J=0:1
SET N=$ORDER(^PSNDF(50.68,"ANDC",P3,N))
if 'N
QUIT
SET LIST(J)=$PIECE(^PSNDF(50.67,N,0),"^",2)
+6 QUIT J
+7 ;
CLASS2(IEN) ;RETURNS FIRST 2 PIECES OF ZERO NODE OF 50.605
+1 QUIT $PIECE($GET(^PS(50.605,+IEN,0)),"^",1,2)
+2 ;
CMOP(CODE) ;CODE = 5 CHARACTER CMOP CODE RETURNS PRODUCT NAME
+1 IF CODE=""
QUIT ""
+2 IF '$ORDER(^PSNDF(50.68,"C",CODE,0))
QUIT ""
+3 QUIT $PIECE(^PSNDF(50.68,+$ORDER(^PSNDF(50.68,"C",CODE,0)),0),"^")
+4 ;
FORMRX(DA,K,LIST) ;RETURN X=1 FOR RESTRICTIONS, 0 FOR NO
+1 ;RETURNS LIST=WORD PROCESSING FIELD FOR RESTRICTIONS
+2 ;
+3 IF '$ORDER(^PSNDF(50.68,+K,6,0))
QUIT 0
+4 MERGE LIST=^PSNDF(50.68,+K,6)
QUIT 1
+5 ;
DDIEX(DA,K) ;RETURN X=1 FOR EXCLUDE DDI CHECK, 0 FOR CONTINUE DDI CHECK
+1 ;
+2 IF '$GET(^PSNDF(50.68,+K,8))
QUIT 0
+3 IF $GET(^PSNDF(50.68,+K,8))
QUIT 1
+4 ;
OVRIDE(PSNPOV1,PSNPOV3) ;Return Override Dose Form Exclusion
+1 IF '$GET(PSNPOV3)
QUIT ""
+2 QUIT $PIECE($GET(^PSNDF(50.68,+PSNPOV3,9)),"^")
+3 ;
FDAMG(IEN) ;RETURN URL FOR MED GUIDE OR NULL
+1 QUIT $PIECE($GET(^PSNDF(50.68,IEN,"MG")),"^")
+2 ;
POSDOS(IEN) ; Return Possible Dosage Auto-Creation Related fields
+1 ; Input: IEN - VA Product (#50.68) IEN
+2 ;Output: Possible Dosage Creation field (separated by "^")
+3 ; 1. CREATE DEFAULT POSSIBLE DOSAGE (Y/N) - Field #40
+4 ; 2. POSSIBLE DOSAGES TO CREATE (N/O/B) - Field #41
+5 ; 3. PACKAGE (I/O/IO) - Field #42
+6 ;
+7 QUIT $GET(^PSNDF(50.68,IEN,"DOS"))
+8 ;
INTRAN(SCR) ; input transform lookup for fields that store NDC codes
+1 ; Input: SCR - (optional) M code for value of DIC("S") - If SCR is not
+2 ; defined, all active entries will be returned
+3 ;
+4 ; Output: The variable X will be returned if input is valid. If no valid
+5 ; input is available, X will be not be returned.
+6 ;
+7 NEW D,DIC,Y
+8 SET DIC("S")="I $P(^(0),U,7)=""""!($P(^(0),U,7)>DT)"
+9 IF $GET(SCR)'=""
SET DIC("S")=SCR
+10 SET DIC="^PSNDF(50.67,"
SET DIC(0)="EMQZ"
+11 SET D="A"
DO IX^DIC
+12 IF +$GET(Y)>0
SET X=$PIECE(Y(0),"^",2)
+13 IF $GET(Y)=-1
KILL X
+14 QUIT
+15 ;
DRGCLS(IEN) ; return class and parent class for NDC
+1 ; Input: IEN - (required) internal entry number of NDC in file 50.67
+2 ;
+3 ; Output: Drug Class code^Parent Class
+4 NEW PSNP,PSNDC,PSNCLS
+5 SET PSNCLS=""
+6 SET PSNP=$PIECE($GET(^PSNDF(50.67,IEN,0)),"^",6)
if 'PSNP
QUIT PSNCLS
+7 SET PSNDC=$PIECE($GET(^PSNDF(50.68,PSNP,3)),"^")
if 'PSNDC
QUIT PSNCLS
+8 SET PSNCLS=$$GET1^DIQ(50.605,PSNDC,.01)_"^"_$$GET1^DIQ(50.605,PSNDC,2)
+9 QUIT PSNCLS
+10 ;
QLIST(SCR) ; executable help ("?" or "??") for fields that store NDC codes
+1 ; Input: SCR - (optional) M code for value of DIC("S") - If SCR is not
+2 ; defined, all active entries will be returned
+3 NEW D,DIC,DO,X
+4 SET DIC("S")="I $P(^(0),U,7)=""""!($P(^(0),U,7)>DT)"
+5 IF $GET(SCR)'=""
SET DIC("S")=SCR
+6 SET X="?"
SET DIC="^PSNDF(50.67,"
SET DIC(0)="EQS"
SET D="NDC"
+7 DO IX^DIC
+8 QUIT
+9 ;
CPTIER(VAPIEN,DATE,PSNDRIEN,PSNCINQS) ; RETURN COPAY TIER INFORMATION (FMCT)
+1 ;Input: VAPIEN - VA Product (#50.68) IEN
+2 ; DATE - Date to be verified for Copay Tier
+3 ; PSNDRIEN - Drug file (#50) IEN.
+4 ; PSNCINQS - 1 if an inquiry screen, null if called by IB
+5 ; The VAPIEN and/or the PSNDRIEN may be passed; however, the PSNDRIEN takes precedence.
+6 ; If the PSNDRIEN variable isn't defined, the VAPIEN IEN will be processed.
+7 ;
+8 ;Output: Tier^Effective Date^End Date
+9 ;
+10 ;*************************************************************************************************
+11 ;** Copay Tier Business Rules: (DO NOT REMOVE)
+12 ; - Pharmacy Product System - National (PPS-N) is used to define copay tier information.
+13 ; - A check for the DEA special Handling code for the drug is an additional check made
+14 ; in Pharmacy to determine if a drug is exempt from copay. The copay exempt DEA codes
+15 ; are: I = Investigational Drug, N = Nutritional Supplement and S for Supply Item.
+16 ;
+17 ; Copay Tier determination criteria:
+18 ; 1. For NDF and PDM display screens (i.e. PSNACT, PSNLOOK, PSSDEE, PSS LOOK), this API
+19 ; will return null if the copay tier is not defined or will return the defined copay tier
+20 ; for the given date. If the drug is not matched to NDF, null is returned. If the tier is
+21 ; null, the selection of drug or product screens will not display the Tier field; however,
+22 ; the body of the display will show the Tier and effective date as null.
+23 ;
+24 ; 2. If the DEA Special Handling Code is exempt from copay and regardless of the copay
+25 ; tier value, this API will return zero. OP will not call IB for billing. The DEA Special
+26 ; Handling Code overrides the nationally defined copay tier.
+27 ;
+28 ; 3. The product is matched to NDF:
+29 ; a. If the copay tier is 1, 2, or 3 and the DEA code is NOT exempt from copay, this
+30 ; API will return the defined copay tier. OP will call IB to charge copay. Copay
+31 ; will be charged based on the tier defined.
+32 ; b. If the copay tier is 0 (zero), this API will return 0 (zero). OP will not call
+33 ; IB to charge copay.
+34 ; c. If no copay tier is defined and the product is NOT exempt from copay, this API
+35 ; will return null. OP will call IB to charge copay and IB will default the copay
+36 ; tier to 2.
+37 ;
+38 ; 4. The product is not matched to NDF:
+39 ; a. If the DEA special handling code is NOT exempt from copay, this API will return
+40 ; null. OP will call IB to charge copay. IB will default to copay tier 2 then
+41 ; charge copay.
+42 ;
+43 ; 5. The copay tier does not have a rate defined in IB, this API will return the defined copay
+44 ; tier. OP will call IB to charge copay and IB will default to tier 2 and charge copay.
+45 ;*************************************************************************************************
+46 ;
+47 NEW FLG,I,II,CPTIER,EFFDT,ENDDT,TIER,RETTIER,RETURN,DEASH,DEA,DEAFLG,PSOTIERE
+48 if '$GET(PSNCINQS)
SET PSNCINQS=""
+49 SET RETURN=""
+50 ;SQA TESTING ONLY - S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY"
+51 DO NOW^%DTC
NEW PSOTIERE
+52 ;use copay tiers - new
SET PSOTIERE=1
+53 ;legacy billing - old
IF $PIECE(%,".")<3170227
SET PSOTIERE=0
+54 ;for SQA testing only - bill with copay tiers - new
IF $GET(^XTMP("PSOTIEREFTST",0))
SET PSOTIERE=1
+55 IF 'PSOTIERE
SET RETTIER=""
QUIT RETTIER
+56 ;***** end for regression test
+57 ;
+58 IF $GET(PSNDRIEN)
SET RETURN=$$CPTIER3(RETURN,DATE,PSNDRIEN)
QUIT RETURN
+59 IF $GET(VAPIEN)
SET RETURN=$$CPTIER2(RETURN,DATE,VAPIEN)
QUIT RETURN
+60 QUIT ""
+61 ;
CPTIER2(RETURN,DATE,VAPIEN) ;
+1 IF '$ORDER(^PSNDF(50.68,VAPIEN,10,0))
QUIT ""
+2 ;use copay tiers - new
SET PSOTIERE=1
+3 SET (FLG,II)=0
SET RETTIER=""
+4 FOR
SET II=$ORDER(^PSNDF(50.68,VAPIEN,10,II))
if 'II
QUIT
SET CPTIER=$GET(^PSNDF(50.68,VAPIEN,10,II,0))
IF CPTIER'=""
Begin DoDot:1
+5 SET TIER=$PIECE(CPTIER,"^")
SET EFFDT=$PIECE(CPTIER,"^",2)
SET ENDDT=$PIECE(CPTIER,"^",3)
+6 IF $GET(EFFDT)&($GET(ENDDT))
IF (DATE'<EFFDT&(DATE'>ENDDT))
SET FLG=1
SET RETTIER=CPTIER
+7 IF $GET(EFFDT)&('$GET(ENDDT))
IF DATE'<EFFDT
SET FLG=1
SET RETTIER=CPTIER
End DoDot:1
+8 QUIT RETTIER
+9 ;
CPTIER3(RETURN,DATE,PSNDRIEN) ;
+1 ;
+2 KILL ^TMP($JOB,"PSNAPIS")
+3 DO NDF^PSS50(PSNDRIEN,,,,,"PSNAPIS")
+4 SET (DEAFLG,DEASH)=""
SET DEASH=$$GET1^DIQ(50,PSNDRIEN,3)
+5 IF DEASH'=""
FOR I=1:1:$LENGTH(DEASH)
SET DEA=""
SET DEA=$EXTRACT(DEASH,I)
Begin DoDot:1
+6 IF (",I,S,N,")[(","_DEA_",")
SET DEAFLG=1
End DoDot:1
+7 if $DATA(^TMP($JOB,"PSNAPIS",PSNDRIEN,22))
SET VAPIEN=$PIECE(^TMP($JOB,"PSNAPIS",PSNDRIEN,22),"^")
+8 ;not matched to NDF
+9 ;I VAPIEN="" S RETURN=$S($G(PSNCINQS):"",'$G(PSNCINQS):0,1:"") Q RETURN
+10 IF VAPIEN=""
SET RETURN=""
QUIT RETURN
+11 ;matched to NDF
+12 SET RETURN=$$CPTIER2(RETURN,DATE,VAPIEN)
+13 ;MATCHED
IF +RETURN=""
Begin DoDot:1
+14 IF $GET(PSNCINQS)
SET RETURN=""
QUIT
+15 SET RETURN=0
End DoDot:1
QUIT RETURN
+16 ;DEA special handling code is exempt from copay
+17 IF $GET(DEAFLG)&('$DATA(RETURN))
Begin DoDot:1
+18 IF $GET(PSNCINQS)
SET RETURN=""
QUIT
+19 SET RETURN=0
End DoDot:1
QUIT RETURN
+20 KILL ^TMP($JOB,"PSNAPIS")
+21 ;otherwise return defined copay tier info
+22 QUIT RETURN
+23 ;
