- PSAVER6 ;BIR/JMB-Verify Invoices - CONT'D ;10/3/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**1,3,21,42,53**; 10/24/97
- ;Background Job:
- ;References to ^PSDRUG( are covered by IA #2095
- ;This routine increments pharmacy location and master vault balances
- ;in 58.8 after invoices have been verified.
- ;
- START ;|=> *42 add Post Verify variance report
- K ^TMP($J,"PSADD")
- K DIC,DA,DR,DIE
- S PSAIEN=0 F S PSAIEN=+$O(PSAVBKG(PSAIEN)) Q:'PSAIEN D
- .Q:'$D(^PSD(58.811,PSAIEN,0))
- .S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^"),PSAVEND=$P(^(0),"^",2),PSAIEN1=0
- .F S PSAIEN1=+$O(PSAVBKG(PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
- ..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- ..S PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
- ..K DIC,DA,DR,DIE
- ..I +$P(PSAIN,"^",13) K DA S DIE="^PSD(58.811,"_PSAIEN_",1,",DA(1)=PSAIEN,DA=PSAIEN1,DR="2////C" D ^DIE K DIE,DA,DR Q
- ..S PSAINV=$P(PSAIN,"^"),PSAINVDT=$P(PSAIN,"^",2),PSALINE=0
- ..F S PSALINE=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:'PSALINE D
- ...Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
- ...S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0) D GETDATA I 'PSASUP,'$D(PSA0QTY) D FILE ;PSA*3*42
- ..K DIC,DA,DR,DIE
- ..K DA S DIE="^PSD(58.811,"_PSAIEN_",1,",DA(1)=PSAIEN,DA=PSAIEN1,DR="2////C" D ^DIE K DIE,DA,DR
- S PSAIEN=0 F S PSAIEN=+$O(PSAVBKG(PSAIEN)) Q:'PSAIEN D
- .Q:'$D(^PSD(58.811,PSAIEN,0))
- .S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^"),PSAVEND=$P(^(0),"^",2),PSAIEN1=0
- .F S PSAIEN1=+$O(PSAVBKG(PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
- ..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- ..D SCANDIF
- ; *42 <=|
- EXIT ;Kills variables
- K %,DA,DD,DIC,DIE,DINUM,DLAYGO,DO,PSA,PSAA,PSABAL,PSACBAL,PSACNT,PSACNT,PSACOD,PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
- K PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALINE,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
- K PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
- K PSA0QTY
- Q
- ;
- GETDATA ;Gets invoice data to help file the data
- S PSAVDUZ=$P(PSADATA,"^",9),PSASUP=0
- S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
- I '$G(PSADJ) S PSADRG=$S(+$P(PSADATA,"^",2):+$P(PSADATA,"^",2),1:0) G CS
- I $G(PSADJ) D
- .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- .I PSADJD'?1.N S PSASUP=1
- .S PSADRG=$S(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2))
- .I +PSADJD,$L(PSADJD)=+$L(PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S PSADRG=+PSADJD Q
- .I +PSADJD,$L(PSADJD)=+$L(PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q
- CS Q:PSASUP!('PSADRG)
- S PSACS=$S(+$P(PSADATA,"^",10):1,1:0)
- S PSADJQ=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- ;
- ;PSA*3*1 (DAVE B)
- S PSAQTY=$S(($G(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$P(PSADATA,"^",3))
- S PSAOU=$S(+$P(PSADATA,"^",4):+$P(PSADATA,"^",4),1:"")
- ;
- ;DAVE B (PSA*3*3)
- ;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
- ;
- S PSADJO=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- S:$G(PSADJO) PSAOU=$G(PSADJO)
- S PSANDC=$P(PSADATA,"^",11) D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
- S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
- S (PSAPOU,PSANPOU)=$S($G(PSADJP):PSADJP,1:+$P(PSADATA,"^",5)),PSALEN=$L($P(PSANPOU,".")),(PSAPOU,PSANPOU)=$J(PSANPOU,PSALEN,2)
- S PSAVSN=$P(PSADATA,"^",12)
- S PSALOC=$S(+PSACS:+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5))
- TEMP S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4)
- S PSADUOU=$S(+PSADUOU:+PSADUOU,+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
- S PSADUREC=$S(PSADUOU:PSAQTY*PSADUOU,1:0)
- ;
- ;DAVE B (18NOV98)
- I PSADUREC=0,$D(PSAQTY),$P($G(^PSDRUG(PSADRG,660)),"^",5)'="" S PSADUREC=(PSAQTY*($P(^PSDRUG(PSADRG,660),"^",5)))
- Q:'+$P($G(^PSD(58.8,PSALOC,0)),"^",14)
- S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5):+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5),1:0)
- S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3):+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3),1:0)
- K PSA0QTY I '$G(PSAQTY),'$G(PSADJQ) S PSA0QTY=1 Q ;PSA*3*42 (0 QTY)
- Q
- ;
- FILE ;File data in 58.8
- I $D(PSADUREC),PSADUREC'>0 S PSADUREC=$S($D(PSADJQ):PSADJQ,$D(PSAQTY):PSAQTY,1:0)
- D NOW^%DTC S PSADT=+$E(%,1,14)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
- .K DIC,DA,DR,DIE
- .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
- .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8
- .F L +^PSD(58.8,PSALOC,0):0 I Q
- .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
- .D MM ;*42 send mailmessage
- F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q
- S PSABAL=+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- ;
- ;DAVE B (PSA*3*3)
- I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
- .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
- S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
- .K DIC,DA,DR,DIE
- .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)"
- .S (X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC("DR")
- .S X="T-1M" D ^%DT S (X,DINUM)=$E(Y,1,5)*100,DA=PSADRG D ^DIC K DIC,DLAYGO
- .K DIC,DA,DR,DIE
- .S DA=+Y,DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
- K DIC,DA,DR,DIE
- S DA=$E(DT,1,5)*100
- S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="3////^S X=($G(PSABAL)+$G(PSADUREC));5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- G TR^PSAVER7
- MM ;
- ;*42 Mail Message to holders of PSDMGR, PSAMGR key
- ;*53 Consolidate messages
- N PSACS S PSACS=$S($$GET1^DIQ(50,PSADRG,63)["N":" Controlled Substance ",1:"")
- S ^TMP($J,"PSADD",$$GET1^DIQ(58.8,PSALOC,.01),$$GET1^DIQ(50,PSADRG,.01))=""
- Q
- SCANDIF ;*42 inspect invoice for noted differences in OU,DUOU,PPDU,NDC
- ;NEEDS PSAIEN, PSAIEN1
- K ^TMP($J,"PSADIF"),PSADIFLC
- S PSALINE=0 F S PSALINE=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:PSALINE'>0 D CHECK^PSAPROC7 ;checks and stores differences in ^TMP($J,
- I $D(^TMP($J,"PSADD")) D ADDMM
- I $D(^TMP($J,"PSADIF")) D MESSAGE
- Q
- MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES.
- K DIR N IENS
- S PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01),IENS=PSAIEN1_","_PSAIEN
- S PSAINV=$$GET1^DIQ(58.8112,IENS,.01)
- S XMSUB="POST Verify Variance Report Ord: "_PSAORD_" Inv: "_PSAINV ;*52
- S ^TMP($J,"PSADIF",1,0)=XMSUB,^TMP($J,"PSADIF",2,0)=" "
- S XMTEXT="^TMP($J,""PSADIF"",",XMY("G.PSA NDC UPDATES")=""
- S XMDUZ="Price & NDC Updater"
- D ^XMD
- K PSADIFLC,^TMP($J,"PSADIF")
- Q
- ADDMM ; SEND MESSAGE REGARDING DRUGS ADDED TO PHARMACY LOCATIONS
- K ^TMP($J,"PSADDMM")
- S XMSUB="New Drugs Added by Order: "_$G(PSAORD)_" Invoice: "_$G(PSAINV)
- S XMDUZ="Verified by: "_$$GET1^DIQ(200,DUZ,.01)
- S LC=0,X=XMSUB D MMLINE S X=XMDUZ D MMLINE
- S X="Please use DA and CS menus to populate the balances, stock and re-order levels." D MMLINE
- S PSALOC="" F S PSALOC=$O(^TMP($J,"PSADD",PSALOC)) Q:PSALOC="" D
- . S X=PSALOC D MMLINE
- . S PSADRG="" F S PSADRG=$O(^TMP($J,"PSADD",PSALOC,PSADRG)) Q:PSADRG="" S X=" "_PSADRG D MMLINE
- S XMTEXT="^TMP($J,""PSADDMM"","
- S XMY("G.PSA NDC UPDATES")=""
- D ^XMD
- K ^TMP($J,"PSADD"),^TMP($J,"PSADDMM"),LC
- Q
- MMLINE S LC=LC+1,^TMP($J,"PSADDMM",LC,0)=X W !,X Q
- PSAVER6 ;BIR/JMB-Verify Invoices - CONT'D ;10/3/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**1,3,21,42,53**; 10/24/97
- +2 ;Background Job:
- +3 ;References to ^PSDRUG( are covered by IA #2095
- +4 ;This routine increments pharmacy location and master vault balances
- +5 ;in 58.8 after invoices have been verified.
- +6 ;
- START ;|=> *42 add Post Verify variance report
- +1 KILL ^TMP($JOB,"PSADD")
- +2 KILL DIC,DA,DR,DIE
- +3 SET PSAIEN=0
- FOR
- SET PSAIEN=+$ORDER(PSAVBKG(PSAIEN))
- IF 'PSAIEN
- QUIT
- Begin DoDot:1
- +4 IF '$DATA(^PSD(58.811,PSAIEN,0))
- QUIT
- +5 SET PSAORD=$PIECE(^PSD(58.811,PSAIEN,0),"^")
- SET PSAVEND=$PIECE(^(0),"^",2)
- SET PSAIEN1=0
- +6 FOR
- SET PSAIEN1=+$ORDER(PSAVBKG(PSAIEN,PSAIEN1))
- IF 'PSAIEN1
- QUIT
- Begin DoDot:2
- +7 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- QUIT
- +8 SET PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
- +9 KILL DIC,DA,DR,DIE
- +10 IF +$PIECE(PSAIN,"^",13)
- KILL DA
- SET DIE="^PSD(58.811,"_PSAIEN_",1,"
- SET DA(1)=PSAIEN
- SET DA=PSAIEN1
- SET DR="2////C"
- DO ^DIE
- KILL DIE,DA,DR
- QUIT
- +11 SET PSAINV=$PIECE(PSAIN,"^")
- SET PSAINVDT=$PIECE(PSAIN,"^",2)
- SET PSALINE=0
- +12 FOR
- SET PSALINE=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))
- IF 'PSALINE
- QUIT
- Begin DoDot:3
- +13 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
- QUIT
- +14 ;PSA*3*42
- SET PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)
- DO GETDATA
- IF 'PSASUP
- IF '$DATA(PSA0QTY)
- DO FILE
- End DoDot:3
- +15 KILL DIC,DA,DR,DIE
- +16 KILL DA
- SET DIE="^PSD(58.811,"_PSAIEN_",1,"
- SET DA(1)=PSAIEN
- SET DA=PSAIEN1
- SET DR="2////C"
- DO ^DIE
- KILL DIE,DA,DR
- End DoDot:2
- End DoDot:1
- +17 SET PSAIEN=0
- FOR
- SET PSAIEN=+$ORDER(PSAVBKG(PSAIEN))
- IF 'PSAIEN
- QUIT
- Begin DoDot:1
- +18 IF '$DATA(^PSD(58.811,PSAIEN,0))
- QUIT
- +19 SET PSAORD=$PIECE(^PSD(58.811,PSAIEN,0),"^")
- SET PSAVEND=$PIECE(^(0),"^",2)
- SET PSAIEN1=0
- +20 FOR
- SET PSAIEN1=+$ORDER(PSAVBKG(PSAIEN,PSAIEN1))
- IF 'PSAIEN1
- QUIT
- Begin DoDot:2
- +21 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- QUIT
- +22 DO SCANDIF
- End DoDot:2
- End DoDot:1
- +23 ; *42 <=|
- EXIT ;Kills variables
- +1 KILL %,DA,DD,DIC,DIE,DINUM,DLAYGO,DO,PSA,PSAA,PSABAL,PSACBAL,PSACNT,PSACNT,PSACOD,PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
- +2 KILL PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALINE,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
- +3 KILL PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
- +4 KILL PSA0QTY
- +5 QUIT
- +6 ;
- GETDATA ;Gets invoice data to help file the data
- +1 SET PSAVDUZ=$PIECE(PSADATA,"^",9)
- SET PSASUP=0
- +2 SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
- +3 IF '$GET(PSADJ)
- SET PSADRG=$SELECT(+$PIECE(PSADATA,"^",2):+$PIECE(PSADATA,"^",2),1:0)
- GOTO CS
- +4 IF $GET(PSADJ)
- Begin DoDot:1
- +5 SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- +6 SET PSADJD=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +7 IF PSADJD'?1.N
- SET PSASUP=1
- +8 SET PSADRG=$SELECT(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):0,1:+$PIECE(PSADATA,"^",2))
- +9 IF +PSADJD
- IF $LENGTH(PSADJD)=+$LENGTH(PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")'=""
- SET PSADRG=+PSADJD
- QUIT
- +10 IF +PSADJD
- IF $LENGTH(PSADJD)=+$LENGTH(PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")=""
- SET (PSADJ,PSADRG)=0
- QUIT
- End DoDot:1
- CS IF PSASUP!('PSADRG)
- QUIT
- +1 SET PSACS=$SELECT(+$PIECE(PSADATA,"^",10):1,1:0)
- +2 SET PSADJQ=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
- +3 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- SET PSADJQ=$SELECT($PIECE(PSANODE,"^",6)'="":+$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +4 ;
- +5 ;PSA*3*1 (DAVE B)
- +6 SET PSAQTY=$SELECT(($GET(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$PIECE(PSADATA,"^",3))
- +7 SET PSAOU=$SELECT(+$PIECE(PSADATA,"^",4):+$PIECE(PSADATA,"^",4),1:"")
- +8 ;
- +9 ;DAVE B (PSA*3*3)
- +10 ;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
- +11 ;
- +12 SET PSADJO=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
- +13 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- SET PSADJO=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +14 IF $GET(PSADJO)
- SET PSAOU=$GET(PSADJO)
- +15 SET PSANDC=$PIECE(PSADATA,"^",11)
- DO PSANDC1^PSAHELP
- SET PSADASH=PSANDCX
- KILL PSANDCX
- +16 SET PSADJP=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
- +17 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- SET PSADJP=$SELECT(+$PIECE(PSANODE,"^",6):+$PIECE(PSANODE,"^",6),1:+$PIECE(PSANODE,"^",2))
- +18 SET (PSAPOU,PSANPOU)=$SELECT($GET(PSADJP):PSADJP,1:+$PIECE(PSADATA,"^",5))
- SET PSALEN=$LENGTH($PIECE(PSANPOU,"."))
- SET (PSAPOU,PSANPOU)=$JUSTIFY(PSANPOU,PSALEN,2)
- +19 SET PSAVSN=$PIECE(PSADATA,"^",12)
- +20 SET PSALOC=$SELECT(+PSACS:+$PIECE(PSAIN,"^",12),1:+$PIECE(PSAIN,"^",5))
- TEMP SET PSATEMP=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- +1 SET PSADUOU=+$PIECE(PSATEMP,"^")
- SET PSAREORD=+$PIECE(PSATEMP,"^",2)
- SET PSASUB=+$PIECE(PSATEMP,"^",3)
- SET PSASTOCK=+$PIECE(PSATEMP,"^",4)
- +2 SET PSADUOU=$SELECT(+PSADUOU:+PSADUOU,+PSASUB&(+$PIECE($GET(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$PIECE($GET(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
- +3 SET PSADUREC=$SELECT(PSADUOU:PSAQTY*PSADUOU,1:0)
- +4 ;
- +5 ;DAVE B (18NOV98)
- +6 IF PSADUREC=0
- IF $DATA(PSAQTY)
- IF $PIECE($GET(^PSDRUG(PSADRG,660)),"^",5)'=""
- SET PSADUREC=(PSAQTY*($PIECE(^PSDRUG(PSADRG,660),"^",5)))
- +7 IF '+$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
- QUIT
- +8 SET PSAREORD=$SELECT(+PSAREORD:+PSAREORD,+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5):+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5),1:0)
- +9 SET PSASTOCK=$SELECT(+PSASTOCK:+PSASTOCK,+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3):+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3),1:0)
- +10 ;PSA*3*42 (0 QTY)
- KILL PSA0QTY
- IF '$GET(PSAQTY)
- IF '$GET(PSADJQ)
- SET PSA0QTY=1
- QUIT
- +11 QUIT
- +12 ;
- FILE ;File data in 58.8
- +1 IF $DATA(PSADUREC)
- IF PSADUREC'>0
- SET PSADUREC=$SELECT($DATA(PSADJQ):PSADJQ,$DATA(PSAQTY):PSAQTY,1:0)
- +2 DO NOW^%DTC
- SET PSADT=+$EXTRACT(%,1,14)
- +3 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
- Begin DoDot:1
- +4 KILL DIC,DA,DR,DIE
- +5 IF '$DATA(^PSD(58.8,PSALOC,1,0))
- SET DIC("P")=$PIECE(^DD(58.8,10,0),"^",2)
- +6 SET DA(1)=PSALOC
- SET DIC="^PSD(58.8,"_DA(1)_",1,"
- SET (DA,DINUM,X)=PSADRG
- SET DIC(0)="L"
- SET DLAYGO=58.8
- +7 FOR
- LOCK +^PSD(58.8,PSALOC,0):0
- IF $TEST
- QUIT
- +8 DO FILE^DICN
- LOCK -^PSD(58.8,PSALOC,0)
- KILL DIC,DA,DLAYGO
- +9 ;*42 send mailmessage
- DO MM
- End DoDot:1
- +10 FOR
- LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):0
- IF $TEST
- QUIT
- +11 SET PSABAL=+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- +12 ;
- +13 ;DAVE B (PSA*3*3)
- +14 IF $PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- +15 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- +16 IF +$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
- Begin DoDot:1
- +17 IF PSASTOCK'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- +18 IF PSAREORD'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
- End DoDot:1
- +19 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,0))
- SET DIC("P")=$PIECE(^DD(58.8001,20,0),"^",2)
- +20 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,$EXTRACT(DT,1,5)*100,0))
- Begin DoDot:1
- +21 KILL DIC,DA,DR,DIE
- +22 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
- SET DIC(0)="L"
- SET DIC("DR")="1////^S X=$G(PSABAL)"
- +23 SET (X,DINUM)=$EXTRACT(DT,1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSADRG
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC("DR")
- +24 SET X="T-1M"
- DO ^%DT
- SET (X,DINUM)=$EXTRACT(Y,1,5)*100
- SET DA=PSADRG
- DO ^DIC
- KILL DIC,DLAYGO
- +25 KILL DIC,DA,DR,DIE
- +26 SET DA=+Y
- SET DA(2)=PSALOC
- SET DA(1)=PSADRG
- SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,"
- SET DR="3////^S X=$G(PSABAL)"
- DO ^DIE
- KILL DIE
- End DoDot:1
- +27 KILL DIC,DA,DR,DIE
- +28 SET DA=$EXTRACT(DT,1,5)*100
- +29 SET DA(2)=PSALOC
- SET DA(1)=PSADRG
- SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,"
- SET DA=$EXTRACT(DT,1,5)*100
- SET DR="3////^S X=($G(PSABAL)+$G(PSADUREC));5////^S X="_($PIECE($GET(^(0)),"^",3)+PSADUREC)
- DO ^DIE
- KILL DIE
- +30 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
- +31 GOTO TR^PSAVER7
- MM ;
- +1 ;*42 Mail Message to holders of PSDMGR, PSAMGR key
- +2 ;*53 Consolidate messages
- +3 NEW PSACS
- SET PSACS=$SELECT($$GET1^DIQ(50,PSADRG,63)["N":" Controlled Substance ",1:"")
- +4 SET ^TMP($JOB,"PSADD",$$GET1^DIQ(58.8,PSALOC,.01),$$GET1^DIQ(50,PSADRG,.01))=""
- +5 QUIT
- SCANDIF ;*42 inspect invoice for noted differences in OU,DUOU,PPDU,NDC
- +1 ;NEEDS PSAIEN, PSAIEN1
- +2 KILL ^TMP($JOB,"PSADIF"),PSADIFLC
- +3 ;checks and stores differences in ^TMP($J,
- SET PSALINE=0
- FOR
- SET PSALINE=$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))
- IF PSALINE'>0
- QUIT
- DO CHECK^PSAPROC7
- +4 IF $DATA(^TMP($JOB,"PSADD"))
- DO ADDMM
- +5 IF $DATA(^TMP($JOB,"PSADIF"))
- DO MESSAGE
- +6 QUIT
- MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES.
- +1 KILL DIR
- NEW IENS
- +2 SET PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01)
- SET IENS=PSAIEN1_","_PSAIEN
- +3 SET PSAINV=$$GET1^DIQ(58.8112,IENS,.01)
- +4 ;*52
- SET XMSUB="POST Verify Variance Report Ord: "_PSAORD_" Inv: "_PSAINV
- +5 SET ^TMP($JOB,"PSADIF",1,0)=XMSUB
- SET ^TMP($JOB,"PSADIF",2,0)=" "
- +6 SET XMTEXT="^TMP($J,""PSADIF"","
- SET XMY("G.PSA NDC UPDATES")=""
- +7 SET XMDUZ="Price & NDC Updater"
- +8 DO ^XMD
- +9 KILL PSADIFLC,^TMP($JOB,"PSADIF")
- +10 QUIT
- ADDMM ; SEND MESSAGE REGARDING DRUGS ADDED TO PHARMACY LOCATIONS
- +1 KILL ^TMP($JOB,"PSADDMM")
- +2 SET XMSUB="New Drugs Added by Order: "_$GET(PSAORD)_" Invoice: "_$GET(PSAINV)
- +3 SET XMDUZ="Verified by: "_$$GET1^DIQ(200,DUZ,.01)
- +4 SET LC=0
- SET X=XMSUB
- DO MMLINE
- SET X=XMDUZ
- DO MMLINE
- +5 SET X="Please use DA and CS menus to populate the balances, stock and re-order levels."
- DO MMLINE
- +6 SET PSALOC=""
- FOR
- SET PSALOC=$ORDER(^TMP($JOB,"PSADD",PSALOC))
- IF PSALOC=""
- QUIT
- Begin DoDot:1
- +7 SET X=PSALOC
- DO MMLINE
- +8 SET PSADRG=""
- FOR
- SET PSADRG=$ORDER(^TMP($JOB,"PSADD",PSALOC,PSADRG))
- IF PSADRG=""
- QUIT
- SET X=" "_PSADRG
- DO MMLINE
- End DoDot:1
- +9 SET XMTEXT="^TMP($J,""PSADDMM"","
- +10 SET XMY("G.PSA NDC UPDATES")=""
- +11 DO ^XMD
- +12 KILL ^TMP($JOB,"PSADD"),^TMP($JOB,"PSADDMM"),LC
- +13 QUIT
- MMLINE SET LC=LC+1
- SET ^TMP($JOB,"PSADDMM",LC,0)=X
- WRITE !,X
- QUIT
