- 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
- 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
