PSSPOIC ;BIR/RTR-Orderable items by VA Name after Primary ; 09/01/98 7:10
;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
I '$G(PSMATCH) G CANT
;VA Generic Name after Primary checks that can auto-match
BEG F PPP=0:0 S PPP=$O(^PSDRUG(PPP)) Q:'PPP D
.S NDNOD=$G(^PSDRUG(PPP,"ND")),PSODNAME=$P($G(^(0)),"^"),PRIPTR=$P($G(^(2)),"^",6),PSOIPTR=$P($G(^(2)),"^") S DA=$P($G(PSNDO),"^"),K=$P($G(PSNDO),"^",3),X=$$PSJDF^PSNAPIS(DA,K),DOFO=X
.Q:PSODNAME=""
.I $D(^TMP("PSS",$J,PSODNAME)) Q
.I +PSOIPTR Q
.K ^TMP($J,"PSSPP") I +$P(NDNOD,"^"),+$P(NDNOD,"^",3) F AA=0:0 S AA=$O(^PSDRUG("AND",+NDNOD,AA)) Q:'AA S OTHNAME=$P($G(^PSDRUG(AA,0)),"^") I $D(^TMP("PSS",$J,OTHNAME)) D
..S ONOD=$G(^PSDRUG(AA,"ND")) I +$P(ONOD,"^"),+$P(ONOD,"^",3),DOFO'=0 S DA=$P($G(ONOD),"^"),K=$P($G(ONOD),"^",3),X=$$PSJDF^PSNAPIS(DA,K),DOFO1=X I DOFO1'=0 D
...I DOFO=DOFO1 S ^TMP($J,"PSSPP",AA)=^TMP("PSS",$J,OTHNAME)
.S (COMM,COMMSUP)=0 I $O(^TMP($J,"PSSPP",0)) S COMM=1 S WW=$O(^TMP($J,"PSSPP",0)),POII=^TMP($J,"PSSPP",WW) F WW=0:0 S WW=$O(^TMP($J,"PSSPP",WW)) Q:'WW I POII'=^TMP($J,"PSSPP",WW) S COMMSUP=1
.I COMM,COMMSUP Q
.I COMM,'COMMSUP S ZZZ=$O(^TMP($J,"PSSPP",0)),ZZZ=^TMP($J,"PSSPP",ZZZ) S ^TMP("PSSD",$J,ZZZ,PSODNAME)="" Q
.I +$P(NDNOD,"^"),+$P(NDNOD,"^",3) S DA=$P($G(NDNOD),"^"),K=$P($G(NDNOD),"^",3),X=$$PSJDF^PSNAPIS(DA,K),D1F1=X I D1F1'=0 D
..S DA=$P($G(NDNOD),"^"),X=$$VAGN^PSNAPIS(DA),VAGN=X I $L(VAGN)<41 D
...S ^TMP("PSSD",$J,VAGN_" "_$P(D1F1,"^",2),PSODNAME)=""
END K ^TMP($J,"PSSPP"),AA,APPU,COMM,COMMSUP,NDNOD,ONOD,OTHNAME,POII,PPP,PSOIPTR,PRIPTR,PSODF,PSODNAME,WW,ZZZ Q
CANT ;Generic Name after Primary, can't match
F LLL=0:0 S LLL=$O(^PSDRUG(LLL)) Q:'LLL D I TMPFLG S ^TMP("PSSD",$J,"ZZZZ",PSNAME)=RSN
.K RSN,DOSFO,POTDOS
.S PSNDO=$G(^PSDRUG(LLL,"ND")),PSNAME=$P($G(^(0)),"^"),PSPTR=$P($G(^(2)),"^"),PSPRIM=$P($G(^(2)),"^",6) S DA=$P($G(PSNDO),"^"),K=$P($G(PSNDO),"^",3),X=$$PSJDF^PSNAPIS(DA,K),FRM1=X,TMPFLG=0
.I +PSPTR Q
.;If Primary, ZZZZ or PSS
.I $D(^TMP("PSS",$J,PSNAME)) Q
.K ^TMP($J,"PSSO") I +$P(PSNDO,"^"),+$P(PSNDO,"^",3) F BB=0:0 S BB=$O(^PSDRUG("AND",+PSNDO,BB)) Q:'BB S OTHER=$P($G(^PSDRUG(BB,0)),"^") I $D(^TMP("PSS",$J,OTHER)) D
..S OTNO=$G(^PSDRUG(BB,"ND")) I +$P(OTNO,"^"),+$P(OTNO,"^",3),FRM1'=0 S DA=$P($G(OTNO),"^"),K=$P($G(OTNO),"^",3),X=$$PSJDF^PSNAPIS(DA,K),FRM2=X I FRM2'=0 D
...I FRM1=FRM2 D
....S SAME=0,POINAME=^TMP("PSS",$J,OTHER) F III=0:0 S III=$O(^TMP($J,"PSSO",III)) Q:'III I POINAME=^(III) S SAME=1
....I 'SAME S ^TMP($J,"PSSO",BB)=^TMP("PSS",$J,OTHER)
.S PSCOMMD=0 I $O(^TMP($J,"PSSO",0)) S TTT=$O(^TMP($J,"PSSO",0)),ORDNAM=^TMP($J,"PSSO",TTT) F TTT=0:0 S TTT=$O(^TMP($J,"PSSO",TTT)) Q:'TTT I ORDNAM'=^TMP($J,"PSSO",TTT) S PSCOMMD=1
.I $O(^TMP($J,"PSSO",0)),'PSCOMMD K ^TMP("PSSD",$J,"ZZZZ",PSNAME) Q
.S CNT=0 I $O(^TMP($J,"PSSO",0)),'$D(^TMP("PSSD",$J,"ZZZZ",PSNAME)) S (CNT,TMPFLG)=1 F NN=0:0 S NN=$O(^TMP($J,"PSSO",NN)) Q:'NN S ^TMP("PSSD",$J,"ZZZZ",PSNAME,CNT)=^TMP($J,"PSSO",NN) S CNT=CNT+1
.I CNT S RSN="Multiple Orderable Items" Q
.S QFLAG=0 I +$P(PSNDO,"^"),+$P(PSNDO,"^",3) S DA=$P($G(PSNDO),"^"),X=$$VAGN^PSNAPIS(DA),VAGN1=X I VAGN1'=0 S DOSFO=$P(FRM1,"^") D
..I DOSFO,$D(^PS(50.606,DOSFO,0)),$L(VAGN1)<41 S QFLAG=1
.I QFLAG K ^TMP("PSSD",$J,"ZZZZ",PSNAME) Q
.I $D(^TMP("PSSD",$J,"ZZZZ",PSNAME)) Q
.S TMPFLG=1
.I $P(PSNDO,"^")="" S RSN="NDF link missing or incomplete" Q
.I $P(PSNDO,"^",3)="" S RSN="No PSNDF VA Product Name Entry" Q
.I VAGN1=0 S RSN="Invalid National Drug File Entry" Q
.S PVA=$P($G(PSNDO),"^",3),DA=$P($G(PSNDO),"^"),K=PVA,X=$$PROD0^PSNAPIS(DA,K) I X']"" S RSN="Invalid PSNDF VA Product Name Entry" Q
.S DA=$P($G(PSNDO),"^"),K=PVA,X=$$PSJDF^PSNAPIS(DA,K),FRM0=X I FRM0=0 S RSN="No Dosage Form entry in NDF" Q
.I FRM0=0 S RSN="Missing Dosage Form in NDF" Q
.I FRM0=0 S RSN="Invalid Entry in Dosage Form File" Q
.I $L(VAGN1)>40 S RSN="Generic name exceeds 40 characters" Q
.S RSN="Undetermined problem" Q
DONE K ^TMP($J,"PSSO"),^TMP("PSS",$J),APL,BB,CNT,DOSFRM,DOSPNT,SAME,LLL,III,NN,ORDNAM,OTHER,OTNO,POINAME,PSCOMMD,PSNAME,PSPTR,PSPRIM,POTDOS,PSNDO,DOSFO,PVA,QFLAG,RSN,TTT,TMPFLG Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPOIC 4138 printed Sep 02, 2024@19:19:17 Page 2
PSSPOIC ;BIR/RTR-Orderable items by VA Name after Primary ; 09/01/98 7:10
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
+2 IF '$GET(PSMATCH)
GOTO CANT
+3 ;VA Generic Name after Primary checks that can auto-match
BEG FOR PPP=0:0
SET PPP=$ORDER(^PSDRUG(PPP))
if 'PPP
QUIT
Begin DoDot:1
+1 SET NDNOD=$GET(^PSDRUG(PPP,"ND"))
SET PSODNAME=$PIECE($GET(^(0)),"^")
SET PRIPTR=$PIECE($GET(^(2)),"^",6)
SET PSOIPTR=$PIECE($GET(^(2)),"^")
SET DA=$PIECE($GET(PSNDO),"^")
SET K=$PIECE($GET(PSNDO),"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET DOFO=X
+2 if PSODNAME=""
QUIT
+3 IF $DATA(^TMP("PSS",$JOB,PSODNAME))
QUIT
+4 IF +PSOIPTR
QUIT
+5 KILL ^TMP($JOB,"PSSPP")
IF +$PIECE(NDNOD,"^")
IF +$PIECE(NDNOD,"^",3)
FOR AA=0:0
SET AA=$ORDER(^PSDRUG("AND",+NDNOD,AA))
if 'AA
QUIT
SET OTHNAME=$PIECE($GET(^PSDRUG(AA,0)),"^")
IF $DATA(^TMP("PSS",$JOB,OTHNAME))
Begin DoDot:2
+6 SET ONOD=$GET(^PSDRUG(AA,"ND"))
IF +$PIECE(ONOD,"^")
IF +$PIECE(ONOD,"^",3)
IF DOFO'=0
SET DA=$PIECE($GET(ONOD),"^")
SET K=$PIECE($GET(ONOD),"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET DOFO1=X
IF DOFO1'=0
Begin DoDot:3
+7 IF DOFO=DOFO1
SET ^TMP($JOB,"PSSPP",AA)=^TMP("PSS",$JOB,OTHNAME)
End DoDot:3
End DoDot:2
+8 SET (COMM,COMMSUP)=0
IF $ORDER(^TMP($JOB,"PSSPP",0))
SET COMM=1
SET WW=$ORDER(^TMP($JOB,"PSSPP",0))
SET POII=^TMP($JOB,"PSSPP",WW)
FOR WW=0:0
SET WW=$ORDER(^TMP($JOB,"PSSPP",WW))
if 'WW
QUIT
IF POII'=^TMP($JOB,"PSSPP",WW)
SET COMMSUP=1
+9 IF COMM
IF COMMSUP
QUIT
+10 IF COMM
IF 'COMMSUP
SET ZZZ=$ORDER(^TMP($JOB,"PSSPP",0))
SET ZZZ=^TMP($JOB,"PSSPP",ZZZ)
SET ^TMP("PSSD",$JOB,ZZZ,PSODNAME)=""
QUIT
+11 IF +$PIECE(NDNOD,"^")
IF +$PIECE(NDNOD,"^",3)
SET DA=$PIECE($GET(NDNOD),"^")
SET K=$PIECE($GET(NDNOD),"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET D1F1=X
IF D1F1'=0
Begin DoDot:2
+12 SET DA=$PIECE($GET(NDNOD),"^")
SET X=$$VAGN^PSNAPIS(DA)
SET VAGN=X
IF $LENGTH(VAGN)<41
Begin DoDot:3
+13 SET ^TMP("PSSD",$JOB,VAGN_" "_$PIECE(D1F1,"^",2),PSODNAME)=""
End DoDot:3
End DoDot:2
End DoDot:1
END KILL ^TMP($JOB,"PSSPP"),AA,APPU,COMM,COMMSUP,NDNOD,ONOD,OTHNAME,POII,PPP,PSOIPTR,PRIPTR,PSODF,PSODNAME,WW,ZZZ
QUIT
CANT ;Generic Name after Primary, can't match
+1 FOR LLL=0:0
SET LLL=$ORDER(^PSDRUG(LLL))
if 'LLL
QUIT
Begin DoDot:1
+2 KILL RSN,DOSFO,POTDOS
+3 SET PSNDO=$GET(^PSDRUG(LLL,"ND"))
SET PSNAME=$PIECE($GET(^(0)),"^")
SET PSPTR=$PIECE($GET(^(2)),"^")
SET PSPRIM=$PIECE($GET(^(2)),"^",6)
SET DA=$PIECE($GET(PSNDO),"^")
SET K=$PIECE($GET(PSNDO),"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET FRM1=X
SET TMPFLG=0
+4 IF +PSPTR
QUIT
+5 ;If Primary, ZZZZ or PSS
+6 IF $DATA(^TMP("PSS",$JOB,PSNAME))
QUIT
+7 KILL ^TMP($JOB,"PSSO")
IF +$PIECE(PSNDO,"^")
IF +$PIECE(PSNDO,"^",3)
FOR BB=0:0
SET BB=$ORDER(^PSDRUG("AND",+PSNDO,BB))
if 'BB
QUIT
SET OTHER=$PIECE($GET(^PSDRUG(BB,0)),"^")
IF $DATA(^TMP("PSS",$JOB,OTHER))
Begin DoDot:2
+8 SET OTNO=$GET(^PSDRUG(BB,"ND"))
IF +$PIECE(OTNO,"^")
IF +$PIECE(OTNO,"^",3)
IF FRM1'=0
SET DA=$PIECE($GET(OTNO),"^")
SET K=$PIECE($GET(OTNO),"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET FRM2=X
IF FRM2'=0
Begin DoDot:3
+9 IF FRM1=FRM2
Begin DoDot:4
+10 SET SAME=0
SET POINAME=^TMP("PSS",$JOB,OTHER)
FOR III=0:0
SET III=$ORDER(^TMP($JOB,"PSSO",III))
if 'III
QUIT
IF POINAME=^(III)
SET SAME=1
+11 IF 'SAME
SET ^TMP($JOB,"PSSO",BB)=^TMP("PSS",$JOB,OTHER)
End DoDot:4
End DoDot:3
End DoDot:2
+12 SET PSCOMMD=0
IF $ORDER(^TMP($JOB,"PSSO",0))
SET TTT=$ORDER(^TMP($JOB,"PSSO",0))
SET ORDNAM=^TMP($JOB,"PSSO",TTT)
FOR TTT=0:0
SET TTT=$ORDER(^TMP($JOB,"PSSO",TTT))
if 'TTT
QUIT
IF ORDNAM'=^TMP($JOB,"PSSO",TTT)
SET PSCOMMD=1
+13 IF $ORDER(^TMP($JOB,"PSSO",0))
IF 'PSCOMMD
KILL ^TMP("PSSD",$JOB,"ZZZZ",PSNAME)
QUIT
+14 SET CNT=0
IF $ORDER(^TMP($JOB,"PSSO",0))
IF '$DATA(^TMP("PSSD",$JOB,"ZZZZ",PSNAME))
SET (CNT,TMPFLG)=1
FOR NN=0:0
SET NN=$ORDER(^TMP($JOB,"PSSO",NN))
if 'NN
QUIT
SET ^TMP("PSSD",$JOB,"ZZZZ",PSNAME,CNT)=^TMP($JOB,"PSSO",NN)
SET CNT=CNT+1
+15 IF CNT
SET RSN="Multiple Orderable Items"
QUIT
+16 SET QFLAG=0
IF +$PIECE(PSNDO,"^")
IF +$PIECE(PSNDO,"^",3)
SET DA=$PIECE($GET(PSNDO),"^")
SET X=$$VAGN^PSNAPIS(DA)
SET VAGN1=X
IF VAGN1'=0
SET DOSFO=$PIECE(FRM1,"^")
Begin DoDot:2
+17 IF DOSFO
IF $DATA(^PS(50.606,DOSFO,0))
IF $LENGTH(VAGN1)<41
SET QFLAG=1
End DoDot:2
+18 IF QFLAG
KILL ^TMP("PSSD",$JOB,"ZZZZ",PSNAME)
QUIT
+19 IF $DATA(^TMP("PSSD",$JOB,"ZZZZ",PSNAME))
QUIT
+20 SET TMPFLG=1
+21 IF $PIECE(PSNDO,"^")=""
SET RSN="NDF link missing or incomplete"
QUIT
+22 IF $PIECE(PSNDO,"^",3)=""
SET RSN="No PSNDF VA Product Name Entry"
QUIT
+23 IF VAGN1=0
SET RSN="Invalid National Drug File Entry"
QUIT
+24 SET PVA=$PIECE($GET(PSNDO),"^",3)
SET DA=$PIECE($GET(PSNDO),"^")
SET K=PVA
SET X=$$PROD0^PSNAPIS(DA,K)
IF X']""
SET RSN="Invalid PSNDF VA Product Name Entry"
QUIT
+25 SET DA=$PIECE($GET(PSNDO),"^")
SET K=PVA
SET X=$$PSJDF^PSNAPIS(DA,K)
SET FRM0=X
IF FRM0=0
SET RSN="No Dosage Form entry in NDF"
QUIT
+26 IF FRM0=0
SET RSN="Missing Dosage Form in NDF"
QUIT
+27 IF FRM0=0
SET RSN="Invalid Entry in Dosage Form File"
QUIT
+28 IF $LENGTH(VAGN1)>40
SET RSN="Generic name exceeds 40 characters"
QUIT
+29 SET RSN="Undetermined problem"
QUIT
End DoDot:1
IF TMPFLG
SET ^TMP("PSSD",$JOB,"ZZZZ",PSNAME)=RSN
DONE KILL ^TMP($JOB,"PSSO"),^TMP("PSS",$JOB),APL,BB,CNT,DOSFRM,DOSPNT,SAME,LLL,III,NN,ORDNAM,OTHER,OTNO,POINAME,PSCOMMD,PSNAME,PSPTR,PSPRIM,POTDOS,PSNDO,DOSFO,PVA,QFLAG,RSN,TTT,TMPFLG
QUIT
