PSAGIP1 ;BIR/LTL,JMB-DA receiving from GIP - CONT'D;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**8**; 10/24/97
N PSACOS,PSACO,PSACOD,PSAPC1,PSAPC2,PSAPC3,PSAFND,PSAONDC,PSAQT,PSAC,DA,DIE,DR,XMDUZ,XMSUB,XMY,XMTEXT
G:'PSACOST!('PSAQTY) NDC
S PSACOS=+$J((PSACOST/PSAQTY),0,3)
S PSACO=$G(^PSDRUG(+PSADRUG,660))
G:PSACOS=+$P(PSACO,U,6)!('$P(PSACO,U,5)) NDC
S PSAQT=$P($G(^PSD(58.8,+PSALOC,1,+PSADRUG,0)),U,4)
I PSAQT>0 S PSACOST=PSACOST+(PSAQT*+$P(PSACO,U,6)),PSAQT=PSAQTY+PSAQT,PSACOS=+$J((PSACOST/PSAQT),0,3)
G:PSACOS=+$P(PSACO,U,6) NDC
S PSAC=+$J((PSACOS*$P(PSACO,U,5)),0,2)
S DIE="^PSDRUG(",DA=PSADRUG
S PSAFND=0,PSAONDC=$P($G(^PSDRUG(PSADRUG,2)),"^",4)
D:PSANDC'=PSAONDC&(PSANDC'="")
.S PSAPC1=$L($P(PSANDC,"-")),PSAPC2=$L($P(PSANDC,"-",2)),PSAPC3=$L($P(PSANDC,"-",3))
.I PSAPC1=4,PSAPC2=4,PSAPC3=2 S PSAFND=1 Q
.I PSAPC1=5,PSAPC2=3,PSAPC3=2 S PSAFND=1 Q
.I PSAPC1=5,PSAPC2=4,PSAPC3=1 S PSAFND=1 Q
.I PSAPC1=5,PSAPC2=4,PSAPC3=2 S PSAFND=1 Q
.I PSAPC1=6,PSAPC2=4,PSAPC3=2 S PSAFND=1
S DR=$S(PSAFND:"13////"_PSAC_";31////"_PSANDC,1:"13////"_PSAC) D ^DIE K DIE,DA
S ^TMP("PSAD",$J,$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25))=$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25)_", Item #"_$P($G(^TMP("PSA",$J,PSADRUG)),U,6)_", Old price: $"_$P(PSACO,U,6)_", New price: $"_PSACOS
I PSANDC'=PSAONDC,PSANDC'="" D
.S ^TMP("PSAD",$J,$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25),1)=" Old NDC: "_$S(PSAONDC'="":PSAONDC,1:"None")_", New NDC: "_PSANDC
.I 'PSAFND S ^TMP("PSAD",$J,$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25),2)=" The new NDC was not entered in the DRUG file due to an invalid format."
END Q:$O(^TMP("PSA",$J,PSADRUG))
N PSAMSG S PSAMSG=$O(^TMP("PSAD",$J,"")) Q:PSAMSG=""
N PSADRG S PSACNT=1,PSADRG=""
F S PSADRG=$O(^TMP("PSAD",$J,PSADRG)) Q:PSADRG="" D
.S ^TMP("PSAMSG",$J,PSACNT)=^TMP("PSAD",$J,PSADRG),PSACNT=PSACNT+1
.S:$D(^TMP("PSAD",$J,PSADRG,1)) ^TMP("PSAMSG",$J,PSACNT)=^TMP("PSAD",$J,PSADRG,1),PSACNT=PSACNT+1
.S:$D(^TMP("PSAD",$J,PSADRG,2)) ^TMP("PSAMSG",$J,PSACNT)=^TMP("PSAD",$J,PSADRG,2),PSACNT=PSACNT+1
S XMDUZ="Price & NDC Updater",XMSUB="DRUG file Price/NDC Update - "_PSAP
S XMY(DUZ)="",XMTEXT="^TMP(""PSAMSG"",$J,"
I $P($G(^PSD(58.8,+PSALOC,4,+$G(PSAGIP),0)),U,3)'="" S XX=$P(^(0),"^",3),XXX="G."_XX,XMY(XXX)="" K XX,XXX
G:'$D(XMY) QUIT D ^XMD
QUIT K ^TMP("PSAD",$J),^TMP("PSAMSG",$J)
Q
NDC ;This is called if the cost has not changed.
S PSAFND=0,PSAONDC=$P($G(^PSDRUG(PSADRUG,2)),"^",4)
G:PSANDC=PSAONDC!(PSANDC="") END
D:PSANDC'=""
.S PSAPC1=$L($P(PSANDC,"-")),PSAPC2=$L($P(PSANDC,"-",2)),PSAPC3=$L($P(PSANDC,"-",3))
.I PSAPC1=4,PSAPC2=4,PSAPC3=2 S PSAFND=1
.I PSAPC1=5,PSAPC2=3,PSAPC3=2 S PSAFND=1
.I PSAPC1=5,PSAPC2=4,PSAPC3=1 S PSAFND=1
.I PSAPC1=5,PSAPC2=4,PSAPC3=2 S PSAFND=1
.I PSAPC1=6,PSAPC2=4,PSAPC3=2 S PSAFND=1
.I PSAFND S DIE="^PSDRUG(",DA=PSADRUG,DR=";31////^S X=PSANDC" D ^DIE K DIE,DA
S ^TMP("PSAD",$J,$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25))=$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25)_", Item #"_$P($G(^TMP("PSA",$J,PSADRUG)),U,6)
S ^TMP("PSAD",$J,$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25),1)=" Old NDC: "_$S(PSAONDC'="":PSAONDC,1:"None")_", New NDC: "_PSANDC
I 'PSAFND S ^TMP("PSAD",$J,$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,25),2)=" The new NDC was not entered in the DRUG file due to an invalid format."
G END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAGIP1 3335 printed Oct 16, 2024@17:50:10 Page 2
PSAGIP1 ;BIR/LTL,JMB-DA receiving from GIP - CONT'D;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**8**; 10/24/97
+2 NEW PSACOS,PSACO,PSACOD,PSAPC1,PSAPC2,PSAPC3,PSAFND,PSAONDC,PSAQT,PSAC,DA,DIE,DR,XMDUZ,XMSUB,XMY,XMTEXT
+3 if 'PSACOST!('PSAQTY)
GOTO NDC
+4 SET PSACOS=+$JUSTIFY((PSACOST/PSAQTY),0,3)
+5 SET PSACO=$GET(^PSDRUG(+PSADRUG,660))
+6 if PSACOS=+$PIECE(PSACO,U,6)!('$PIECE(PSACO,U,5))
GOTO NDC
+7 SET PSAQT=$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRUG,0)),U,4)
+8 IF PSAQT>0
SET PSACOST=PSACOST+(PSAQT*+$PIECE(PSACO,U,6))
SET PSAQT=PSAQTY+PSAQT
SET PSACOS=+$JUSTIFY((PSACOST/PSAQT),0,3)
+9 if PSACOS=+$PIECE(PSACO,U,6)
GOTO NDC
+10 SET PSAC=+$JUSTIFY((PSACOS*$PIECE(PSACO,U,5)),0,2)
+11 SET DIE="^PSDRUG("
SET DA=PSADRUG
+12 SET PSAFND=0
SET PSAONDC=$PIECE($GET(^PSDRUG(PSADRUG,2)),"^",4)
+13 if PSANDC'=PSAONDC&(PSANDC'="")
Begin DoDot:1
+14 SET PSAPC1=$LENGTH($PIECE(PSANDC,"-"))
SET PSAPC2=$LENGTH($PIECE(PSANDC,"-",2))
SET PSAPC3=$LENGTH($PIECE(PSANDC,"-",3))
+15 IF PSAPC1=4
IF PSAPC2=4
IF PSAPC3=2
SET PSAFND=1
QUIT
+16 IF PSAPC1=5
IF PSAPC2=3
IF PSAPC3=2
SET PSAFND=1
QUIT
+17 IF PSAPC1=5
IF PSAPC2=4
IF PSAPC3=1
SET PSAFND=1
QUIT
+18 IF PSAPC1=5
IF PSAPC2=4
IF PSAPC3=2
SET PSAFND=1
QUIT
+19 IF PSAPC1=6
IF PSAPC2=4
IF PSAPC3=2
SET PSAFND=1
End DoDot:1
+20 SET DR=$SELECT(PSAFND:"13////"_PSAC_";31////"_PSANDC,1:"13////"_PSAC)
DO ^DIE
KILL DIE,DA
+21 SET ^TMP("PSAD",$JOB,$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25))=$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25)_", Item #"_$PIECE($GET(^TMP("PSA",$JOB,PSADRUG)),U,6)_", Old price: $"_$PIECE(PSACO,U,6)_", New price: $"_PSACOS
+22 IF PSANDC'=PSAONDC
IF PSANDC'=""
Begin DoDot:1
+23 SET ^TMP("PSAD",$JOB,$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25),1)=" Old NDC: "_$SELECT(PSAONDC'="":PSAONDC,1:"None")_", New NDC: "_PSANDC
+24 IF 'PSAFND
SET ^TMP("PSAD",$JOB,$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25),2)=" The new NDC was not entered in the DRUG file due to an invalid format."
End DoDot:1
END if $ORDER(^TMP("PSA",$JOB,PSADRUG))
QUIT
+1 NEW PSAMSG
SET PSAMSG=$ORDER(^TMP("PSAD",$JOB,""))
if PSAMSG=""
QUIT
+2 NEW PSADRG
SET PSACNT=1
SET PSADRG=""
+3 FOR
SET PSADRG=$ORDER(^TMP("PSAD",$JOB,PSADRG))
if PSADRG=""
QUIT
Begin DoDot:1
+4 SET ^TMP("PSAMSG",$JOB,PSACNT)=^TMP("PSAD",$JOB,PSADRG)
SET PSACNT=PSACNT+1
+5 if $DATA(^TMP("PSAD",$JOB,PSADRG,1))
SET ^TMP("PSAMSG",$JOB,PSACNT)=^TMP("PSAD",$JOB,PSADRG,1)
SET PSACNT=PSACNT+1
+6 if $DATA(^TMP("PSAD",$JOB,PSADRG,2))
SET ^TMP("PSAMSG",$JOB,PSACNT)=^TMP("PSAD",$JOB,PSADRG,2)
SET PSACNT=PSACNT+1
End DoDot:1
+7 SET XMDUZ="Price & NDC Updater"
SET XMSUB="DRUG file Price/NDC Update - "_PSAP
+8 SET XMY(DUZ)=""
SET XMTEXT="^TMP(""PSAMSG"",$J,"
+9 IF $PIECE($GET(^PSD(58.8,+PSALOC,4,+$GET(PSAGIP),0)),U,3)'=""
SET XX=$PIECE(^(0),"^",3)
SET XXX="G."_XX
SET XMY(XXX)=""
KILL XX,XXX
+10 if '$DATA(XMY)
GOTO QUIT
DO ^XMD
QUIT KILL ^TMP("PSAD",$JOB),^TMP("PSAMSG",$JOB)
+1 QUIT
NDC ;This is called if the cost has not changed.
+1 SET PSAFND=0
SET PSAONDC=$PIECE($GET(^PSDRUG(PSADRUG,2)),"^",4)
+2 if PSANDC=PSAONDC!(PSANDC="")
GOTO END
+3 if PSANDC'=""
Begin DoDot:1
+4 SET PSAPC1=$LENGTH($PIECE(PSANDC,"-"))
SET PSAPC2=$LENGTH($PIECE(PSANDC,"-",2))
SET PSAPC3=$LENGTH($PIECE(PSANDC,"-",3))
+5 IF PSAPC1=4
IF PSAPC2=4
IF PSAPC3=2
SET PSAFND=1
+6 IF PSAPC1=5
IF PSAPC2=3
IF PSAPC3=2
SET PSAFND=1
+7 IF PSAPC1=5
IF PSAPC2=4
IF PSAPC3=1
SET PSAFND=1
+8 IF PSAPC1=5
IF PSAPC2=4
IF PSAPC3=2
SET PSAFND=1
+9 IF PSAPC1=6
IF PSAPC2=4
IF PSAPC3=2
SET PSAFND=1
+10 IF PSAFND
SET DIE="^PSDRUG("
SET DA=PSADRUG
SET DR=";31////^S X=PSANDC"
DO ^DIE
KILL DIE,DA
End DoDot:1
+11 SET ^TMP("PSAD",$JOB,$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25))=$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25)_", Item #"_$PIECE($GET(^TMP("PSA",$JOB,PSADRUG)),U,6)
+12 SET ^TMP("PSAD",$JOB,$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25),1)=" Old NDC: "_$SELECT(PSAONDC'="":PSAONDC,1:"None")_", New NDC: "_PSANDC
+13 IF 'PSAFND
SET ^TMP("PSAD",$JOB,$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,25),2)=" The new NDC was not entered in the DRUG file due to an invalid format."
+14 GOTO END
