PSSSOLI1 ;BIR/RTR-Manual match Solutions to Orderable Items continued ; 09/01/98 7:13
;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
ADD ;
S PSND=$G(^PSDRUG(PSDISP,"ND")),PSND1=$P(PSND,"^"),PSND3=$P(PSND,"^",3),DA=PSND1,K=PSND3
I PSND1,PSND3 S X=$$PSJDF^PSNAPIS(DA,K) S PSDOSPTR=$P(X,"^")
I $G(PSDOSPTR),$D(^PS(50.606,PSDOSPTR,0)) S PSDOSNM=$P(^(0),"^") W !!?3,"*** Dose Form from NDF: ",PSDOSNM G PASS
W ! K DIC S DIC="^PS(50.606,",DIC(0)="QEAMZ",DIC("A")="Select Dose Form: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G ^PSSSOLIT
S PSDOSPTR=+Y,PSDOSNM=$P($G(^PS(50.606,PSDOSPTR,0)),"^")
PASS S PSOIDOSE=PSDOSPTR W !!,"Solution Name -> ",$G(PSSNAME),!," Volume -> ",$G(PSSVOL),!," Dose Form -> ",PSDOSNM
S XXX=PSSNAME D CHECK
S PSANS=0 I ZZFLAG W $C(7),!!,"There is already an Orderable Item named:",!?5,$P($G(^PS(50.7,ZZFLAG,0)),"^")_" "_$P($G(^PS(50.606,+$P(^(0),"^",2),0)),"^"),!
I K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Match to this Orderable Item" D ^DIR S PSANS=Y K DIR I Y["^"!($D(DTOUT)) G ^PSSSOLIT
I PSANS W !!,"Matching: ",PSSNAME_" "_$G(PSSVOL),!," to",!,$P($G(^PS(50.7,ZZFLAG,0)),"^")_" "_$G(PSDOSNM) W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR G:Y=1 SOMAT^PSSSUTIL G:Y["^"!($D(DTOUT)) ^PSSSOLIT
XDIR W ! K DIR S DIR(0)="F^3:40",DIR("A")="Enter Orderable Item Name" S X=PSSNAME D INPUT I $L(PSSNAME)>2,$L(PSSNAME)<41,'INFLAG S DIR("B")=PSSNAME
D ^DIR K DIR I Y["^"!(Y="")!($D(DUOUT))!($D(DTOUT)) G ^PSSSOLIT
S HOLDOI=X
D INPUT I INFLAG W $C(7),!?5,"??",! G XDIR
S PPFLAG=0 F QQ=0:0 S QQ=$O(^PS(50.7,"ADF",HOLDOI,PSOIDOSE,QQ)) Q:'QQ!(PPFLAG) I QQ,$P($G(^PS(50.7,QQ,0)),"^",3) S PPFLAG=QQ
I PPFLAG W !!,"Matching: ",PSSNAME_" "_$G(PSSVOL),!," to",!,$P($G(^PS(50.7,PPFLAG,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
I W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR K DIR W ! G:Y["^"!($D(DTOUT)) ^PSSSOLIT G:Y=0 XDIR
I PPFLAG S ZZFLAG=PPFLAG G SOMAT^PSSSUTIL
NEW ;Create new entry in 50.7
W !!,"Matching: ",PSSNAME_" "_$G(PSSVOL),!," to",!,HOLDOI_" "_PSDOSNM
W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR K DIR W ! I Y'=1 G XDIR
K DIC,DD,DO S DIC="^PS(50.7,",DIC(0)="L",X=HOLDOI,DIC("DR")=".02////"_PSOIDOSE_";.03////"_1 D FILE^DICN K DIC I Y<1 W !!,"Unable to create entry, try again!",! G XDIR
S PSNEWOI=+Y S SCOUNT=0 F SS=0:0 S SS=$O(^PS(52.7,PSSIEN,3,SS)) Q:'SS S SCOUNT=SCOUNT+1,SYN(SCOUNT)=^(SS,0)
K DIE S DIE="^PS(52.7,",DA=PSSIEN,DR="9////"_PSNEWOI D ^DIE K DIE
I SCOUNT S ^PS(50.7,PSNEWOI,2,0)="^50.72^"_SCOUNT_"^"_SCOUNT F WW=0:0 S WW=$O(SYN(WW)) Q:'WW S ^PS(50.7,PSNEWOI,2,WW,0)=SYN(WW)
S NEWFLAG=1 S PSSOI=PSNEWOI D DIR^PSSPOIM3 I $G(PSSDIR) W !!?3,"Now editing Orderable Item:",!?3,$P(^PS(50.7,PSSOI,0),"^")," ",$P($G(^PS(50.606,+$P(^(0),"^",2),0)),"^") D INACT^PSSSOLIT
K NEWFLAG,PSSDIR D EN^PSSPOIDT(PSSOI) D:'$G(PSSSSS) EN2^PSSHL1(PSSOI,"MAD")
G ^PSSSOLIT
INPUT S INFLAG=0 I X[""""!($A(X)=45)!('(X'?1P.E))!(X?2"z".E) S INFLAG=1
Q
CHECK ;
S (ZZFLAG,ZZXFLAG)=0 F VV=0:0 S VV=$O(^PS(50.7,"ADF",XXX,PSOIDOSE,VV)) Q:'VV S:VV&($P($G(^PS(50.7,VV,0)),"^",3)) (ZZFLAG,ZZXFLAG)=VV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSSOLI1 3190 printed Oct 16, 2024@18:35:07 Page 2
PSSSOLI1 ;BIR/RTR-Manual match Solutions to Orderable Items continued ; 09/01/98 7:13
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
ADD ;
+1 SET PSND=$GET(^PSDRUG(PSDISP,"ND"))
SET PSND1=$PIECE(PSND,"^")
SET PSND3=$PIECE(PSND,"^",3)
SET DA=PSND1
SET K=PSND3
+2 IF PSND1
IF PSND3
SET X=$$PSJDF^PSNAPIS(DA,K)
SET PSDOSPTR=$PIECE(X,"^")
+3 IF $GET(PSDOSPTR)
IF $DATA(^PS(50.606,PSDOSPTR,0))
SET PSDOSNM=$PIECE(^(0),"^")
WRITE !!?3,"*** Dose Form from NDF: ",PSDOSNM
GOTO PASS
+4 WRITE !
KILL DIC
SET DIC="^PS(50.606,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select Dose Form: "
DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
GOTO ^PSSSOLIT
+5 SET PSDOSPTR=+Y
SET PSDOSNM=$PIECE($GET(^PS(50.606,PSDOSPTR,0)),"^")
PASS SET PSOIDOSE=PSDOSPTR
WRITE !!,"Solution Name -> ",$GET(PSSNAME),!," Volume -> ",$GET(PSSVOL),!," Dose Form -> ",PSDOSNM
+1 SET XXX=PSSNAME
DO CHECK
+2 SET PSANS=0
IF ZZFLAG
WRITE $CHAR(7),!!,"There is already an Orderable Item named:",!?5,$PIECE($GET(^PS(50.7,ZZFLAG,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE(^(0),"^",2),0)),"^"),!
+3 IF $TEST
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Match to this Orderable Item"
DO ^DIR
SET PSANS=Y
KILL DIR
IF Y["^"!($DATA(DTOUT))
GOTO ^PSSSOLIT
+4 IF PSANS
WRITE !!,"Matching: ",PSSNAME_" "_$GET(PSSVOL),!," to",!,$PIECE($GET(^PS(50.7,ZZFLAG,0)),"^")_" "_$GET(PSDOSNM)
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this OK"
DO ^DIR
if Y=1
GOTO SOMAT^PSSSUTIL
if Y["^"!($DATA(DTOUT))
GOTO ^PSSSOLIT
XDIR WRITE !
KILL DIR
SET DIR(0)="F^3:40"
SET DIR("A")="Enter Orderable Item Name"
SET X=PSSNAME
DO INPUT
IF $LENGTH(PSSNAME)>2
IF $LENGTH(PSSNAME)<41
IF 'INFLAG
SET DIR("B")=PSSNAME
+1 DO ^DIR
KILL DIR
IF Y["^"!(Y="")!($DATA(DUOUT))!($DATA(DTOUT))
GOTO ^PSSSOLIT
+2 SET HOLDOI=X
+3 DO INPUT
IF INFLAG
WRITE $CHAR(7),!?5,"??",!
GOTO XDIR
+4 SET PPFLAG=0
FOR QQ=0:0
SET QQ=$ORDER(^PS(50.7,"ADF",HOLDOI,PSOIDOSE,QQ))
if 'QQ!(PPFLAG)
QUIT
IF QQ
IF $PIECE($GET(^PS(50.7,QQ,0)),"^",3)
SET PPFLAG=QQ
+5 IF PPFLAG
WRITE !!,"Matching: ",PSSNAME_" "_$GET(PSSVOL),!," to",!,$PIECE($GET(^PS(50.7,PPFLAG,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+6 IF $TEST
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this OK"
DO ^DIR
KILL DIR
WRITE !
if Y["^"!($DATA(DTOUT))
GOTO ^PSSSOLIT
if Y=0
GOTO XDIR
+7 IF PPFLAG
SET ZZFLAG=PPFLAG
GOTO SOMAT^PSSSUTIL
NEW ;Create new entry in 50.7
+1 WRITE !!,"Matching: ",PSSNAME_" "_$GET(PSSVOL),!," to",!,HOLDOI_" "_PSDOSNM
+2 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this OK"
DO ^DIR
KILL DIR
WRITE !
IF Y'=1
GOTO XDIR
+3 KILL DIC,DD,DO
SET DIC="^PS(50.7,"
SET DIC(0)="L"
SET X=HOLDOI
SET DIC("DR")=".02////"_PSOIDOSE_";.03////"_1
DO FILE^DICN
KILL DIC
IF Y<1
WRITE !!,"Unable to create entry, try again!",!
GOTO XDIR
+4 SET PSNEWOI=+Y
SET SCOUNT=0
FOR SS=0:0
SET SS=$ORDER(^PS(52.7,PSSIEN,3,SS))
if 'SS
QUIT
SET SCOUNT=SCOUNT+1
SET SYN(SCOUNT)=^(SS,0)
+5 KILL DIE
SET DIE="^PS(52.7,"
SET DA=PSSIEN
SET DR="9////"_PSNEWOI
DO ^DIE
KILL DIE
+6 IF SCOUNT
SET ^PS(50.7,PSNEWOI,2,0)="^50.72^"_SCOUNT_"^"_SCOUNT
FOR WW=0:0
SET WW=$ORDER(SYN(WW))
if 'WW
QUIT
SET ^PS(50.7,PSNEWOI,2,WW,0)=SYN(WW)
+7 SET NEWFLAG=1
SET PSSOI=PSNEWOI
DO DIR^PSSPOIM3
IF $GET(PSSDIR)
WRITE !!?3,"Now editing Orderable Item:",!?3,$PIECE(^PS(50.7,PSSOI,0),"^")," ",$PIECE($GET(^PS(50.606,+$PIECE(^(0),"^",2),0)),"^")
DO INACT^PSSSOLIT
+8 KILL NEWFLAG,PSSDIR
DO EN^PSSPOIDT(PSSOI)
if '$GET(PSSSSS)
DO EN2^PSSHL1(PSSOI,"MAD")
+9 GOTO ^PSSSOLIT
INPUT SET INFLAG=0
IF X[""""!($ASCII(X)=45)!('(X'?1P.E))!(X?2"z".E)
SET INFLAG=1
+1 QUIT
CHECK ;
+1 SET (ZZFLAG,ZZXFLAG)=0
FOR VV=0:0
SET VV=$ORDER(^PS(50.7,"ADF",XXX,PSOIDOSE,VV))
if 'VV
QUIT
if VV&($PIECE($GET(^PS(50.7,VV,0)),"^",3))
SET (ZZFLAG,ZZXFLAG)=VV
+2 QUIT
