- PSSADDIT ;BIR/RTR/WRT-Manual match Additives to Orderable Items; 09/01/98 7:06
- ;;1.0;PHARMACY DATA MANAGEMENT;**15,32,41,125**;9/30/97;Build 2
- ;
- ;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
- ;
- S PSSITE=+$O(^PS(59.7,0)) I +$P($G(^PS(59.7,PSSITE,80)),"^",2)<2 W !!?3,"Orderable Item Auto-Create has not been completed yet!",! K PSSITE,DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR Q
- K PSSITE W !!,"This option enables you to match IV Additives or IV Solutions to the Pharmacy",!,"Orderable Item File." D END
- SEL K DIR S PSSSSS=0 S DIR(0)="S^A:ADDITIVES;S:SOLUTIONS",DIR("A")="Match Additives or Solutions" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
- I Y="S" G ^PSSSOLIT
- EN I $D(PSAIEN) L -^PS(52.6,PSAIEN)
- D:$G(PSDELFLG) REMAT^PSSSOLIT D:$G(PSMASTER) END Q:$G(PSSSSS)!($G(PSMASTER)) D END W ! K DIC,PSJOUT S DIC="^PS(52.6,",DIC(0)="QEAMZ",DIC("A")="Select IV ADDITIVE: " D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) END
- MAS ;Entry point for Master Enter/Edit
- S PSAIEN=+Y,PSANAME=$P(Y,"^",2),PSDISP=+$P($G(^PS(52.6,PSAIEN,0)),"^",2),PSPOI=$P($G(^(0)),"^",11) L +^PS(52.6,PSAIEN):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I '$T W !,$C(7),"Another person is editing this additive." Q
- I 'PSDISP W $C(7),!!?5,"This IV Additive does not point to the Dispense Drug File (#50)",!?5,"it cannot be matched to an Orderable Item!",! G EN
- ENTER I 'PSPOI G ADD
- S PSOINAME=$P($G(^PS(50.7,PSPOI,0)),"^"),PSOIDOSE=+$P($G(^(0)),"^",2) W !!,"IV ADDITIVE -> ",PSANAME,!," is already matched to:",!,PSOINAME," ",$P($G(^PS(50.606,PSOIDOSE,0)),"^")
- W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to re-match this IV Additive",DIR("B")="NO" D ^DIR K DIR I Y'=1 D SELIV^PSSSOLIT G @$S($G(PSSJI)&('$G(PSSIVOUT)):"ENA^PSSVIDRG",1:"EN")
- S PSDELADD=PSAIEN,PSDELOIT=PSPOI,PSDELFLG=1
- K DIE S DA=PSAIEN,DIE="^PS(52.6,",DR="15////"_"@" D ^DIE D EN^PSSPOIDT(PSPOI),EN2^PSSHL1(PSPOI,"MUP") K PSPOI,PSOINAME,PSOIDOSE G ADD
- INACT W ! K DIE S PSBEFORE=$P(^PS(50.7,PSPOI,0),"^",4),PSAFTER=0,PSINORDE="" S DIE="^PS(50.7,",DR=".04;.05;.06;.07;.08",DA=PSPOI D ^DIE S PSAFTER=$P(^PS(50.7,PSPOI,0),"^",4) K DIE
- S:PSBEFORE&('PSAFTER) PSINORDE="D" S:PSAFTER PSINORDE="I"
- I PSINORDE'="" D REST^PSSPOIDT(PSPOI)
- K PSBEFORE,PSAFTER,PSINORDE
- SYN W ! K DIC S:'$D(^PS(50.7,PSPOI,2,0)) ^PS(50.7,PSPOI,2,0)="^50.72^0^0" S DIC="^PS(50.7,"_PSPOI_",2,",DA(1)=PSPOI,DIC(0)="QEAMZL",DIC("A")="Select SYNONYM: ",DLAYGO=50.7 D ^DIC K DIC
- I Y<0!($D(DTOUT))!($D(DUOUT)) K:'$O(^PS(50.7,PSPOI,2,0)) ^PS(50.7,PSPOI,2,0) Q:$G(NEWFLAG) D:'$G(PSSSSS) EN2^PSSHL1(PSPOI,"MUP") D END G EN
- W ! S DA=+Y,DIE="^PS(50.7,"_PSPOI_",2,",DA(1)=PSPOI,DR=.01 D ^DIE K DIE G SYN
- Q:$G(NEWFLAG) D:'$G(PSSSSS) EN2^PSSHL1(PSPOI,"MUP")
- D END G EN
- 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=VV S:VV&($P($G(^(0)),"^",3))&($D(^PS(52.6,"AOI",VV))) ZZXFLAG=VV
- Q
- END I $D(PSAIEN) L -^PS(52.6,PSAIEN)
- K PSDELADD,PSDELFLG,PSDELOIT,PSSSSS
- K DA,DIC,DR,DTOUT,LL,QQ,HOLDOI,INFLAG,NEWFLAG,PSAIEN,PSANAME,PSDISP,PSDOSNM,PSDOSPTR,PSND,PSND1,PSND3,PSONEW,PSNDOSE,PSNEWOI,PSOIDOSE,PSOINAME,PSPOI,SCOUNT,SS,SYN,SYN1,VV,PFLAG,PFLAGOI,WW,X,XXX,Y,ZZFLAG,PANS,ZZXFLAG,SYNNAM,VV,VVV,TT,SCLAST Q
- ADD ;
- K PSDOSPTR 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)) W !?3,"*** Dose Form from NDF: ",$P($G(^PS(50.606,PSDOSPTR,0)),"^") 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 EN
- S PSDOSPTR=+Y
- PASS S PSDOSNM=$P($G(^PS(50.606,PSDOSPTR,0)),"^"),PSOIDOSE=PSDOSPTR S XXX=PSANAME D CHECK
- I $G(ZZFLAG),'$G(ZZXFLAG) W $C(7),!!,"There is already an Orderable Item named:",!?5,$P($G(^PS(50.7,ZZFLAG,0)),"^")," ",$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),!
- I K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Match to this Orderable Item" D ^DIR K DIR I Y["^"!($D(DTOUT)) G EN
- I $G(ZZFLAG),'$G(ZZXFLAG),$G(Y) W !!,"Matching: ",PSANAME,!," to",!,$P($G(^PS(50.7,+ZZFLAG,0)),"^")_" "_PSDOSNM W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR S PANS=Y G:PANS=1 MAT^PSSSUTIL G:(PANS["^")!($D(DTOUT)) EN
- I $G(ZZXFLAG) W $C(7),!!?5,"You must create a new Orderable Item Name for this IV Additive, since a",!?5,"duplicate already exists with another IV Additive matched to it!",!
- XDIR W !!,"Additive Name -> ",$G(PSANAME),!,"Dose Form -> ",$G(PSDOSNM),!
- S X=PSANAME D INPUT
- K DIR S DIR(0)="F^3:40",DIR("A")="Enter Orderable Item Name" I '$G(ZZXFLAG),'$G(INFLAG),$L(PSANAME)>2,$L(PSANAME)<41 S DIR("B")=PSANAME
- D ^DIR K DIR I Y["^"!(Y="")!($D(DTOUT))!($D(DUOUT)) G EN
- S HOLDOI=X
- D INPUT I INFLAG S X=PSANAME G XDIR
- S (PFLAG,PFLAGOI)=0 F QQ=0:0 S QQ=$O(^PS(50.7,"ADF",X,PSOIDOSE,QQ)) Q:'QQ!(PFLAG) I QQ,$P($G(^PS(50.7,QQ,0)),"^",3)'="" S PFLAG=1,PFLAGOI=QQ
- I PFLAG,$D(^PS(52.6,"AOI",PFLAGOI)) W $C(7),!!,?2,"A duplicate Name and Dose Form entry already exists in the Orderable Item",!,?2,"File, with a corresponding matched IV Additive. You must select another name!" G XDIR
- I PFLAG,'$D(^PS(52.6,"AOI",PFLAGOI)) W !!,"Matching: ",PSANAME,!," to",!,$P($G(^PS(50.7,PFLAGOI,0)),"^")_" "_$G(PSDOSNM) W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR K DIR G:Y["^"!($D(DTOUT)) EN G:Y=0 XDIR
- I PFLAG,'$D(^PS(52.6,"AOI",PFLAGOI)) S ZZFLAG=PFLAGOI G MAT^PSSSUTIL
- NEW ;create new entry in 50.7 and match to it
- W !!,"Matching: ",PSANAME,!," to",!,HOLDOI_" "_$G(PSDOSNM)
- W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR K DIR W ! I Y'=1 S X=PSANAME 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 !!?5,"UNABLE TO CREATE ENTRY, TRY AGAIN!",! G XDIR
- S PSNEWOI=+Y S SCOUNT=0 F SS=0:0 S SS=$O(^PS(52.6,PSAIEN,3,SS)) Q:'SS S SCOUNT=SCOUNT+1,SYN(SCOUNT)=^(SS,0)
- K DIE S DIE="^PS(52.6,",DA=PSAIEN,DR="15////"_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)
- I SCOUNT F LL=0:0 S LL=$O(^PS(50.7,PSNEWOI,2,LL)) Q:'LL S SYNNAM=$P(^(LL,0),"^"),^PS(50.7,PSNEWOI,2,"B",SYNNAM,LL)=""
- S NEWFLAG=1 S PSPOI=PSNEWOI D DIR^PSSPOIM3 I $G(PSSDIR) W !!?3,"Now editing Orderable Item:",!?3,$P(^PS(50.7,PSNEWOI,0),"^")," ",$P($G(^PS(50.606,+$P(^(0),"^",2),0)),"^") D INACT K NEWFLAG
- K NEWFLAG,PSSDIR
- D EN^PSSPOIDT(PSPOI) D:'$G(PSSSSS) EN2^PSSHL1(PSNEWOI,"MAD")
- G EN
- INPUT S INFLAG=0 I X[""""!($A(X)=45)!('(X'?1P.E))!(X?2"z".E) W $C(7),!?5,"??",! S INFLAG=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSADDIT 6709 printed Jan 18, 2025@03:31:03 Page 2
- PSSADDIT ;BIR/RTR/WRT-Manual match Additives to Orderable Items; 09/01/98 7:06
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**15,32,41,125**;9/30/97;Build 2
- +2 ;
- +3 ;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
- +4 ;
- +5 SET PSSITE=+$ORDER(^PS(59.7,0))
- IF +$PIECE($GET(^PS(59.7,PSSITE,80)),"^",2)<2
- WRITE !!?3,"Orderable Item Auto-Create has not been completed yet!",!
- KILL PSSITE,DIR
- SET DIR(0)="E"
- SET DIR("A")="Press RETURN to continue"
- DO ^DIR
- KILL DIR
- QUIT
- +6 KILL PSSITE
- WRITE !!,"This option enables you to match IV Additives or IV Solutions to the Pharmacy",!,"Orderable Item File."
- DO END
- SEL KILL DIR
- SET PSSSSS=0
- SET DIR(0)="S^A:ADDITIVES;S:SOLUTIONS"
- SET DIR("A")="Match Additives or Solutions"
- DO ^DIR
- KILL DIR
- IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO END
- +1 IF Y="S"
- GOTO ^PSSSOLIT
- EN IF $DATA(PSAIEN)
- LOCK -^PS(52.6,PSAIEN)
- +1 if $GET(PSDELFLG)
- DO REMAT^PSSSOLIT
- if $GET(PSMASTER)
- DO END
- if $GET(PSSSSS)!($GET(PSMASTER))
- QUIT
- DO END
- WRITE !
- KILL DIC,PSJOUT
- SET DIC="^PS(52.6,"
- SET DIC(0)="QEAMZ"
- SET DIC("A")="Select IV ADDITIVE: "
- DO ^DIC
- KILL DIC
- if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO END
- MAS ;Entry point for Master Enter/Edit
- +1 SET PSAIEN=+Y
- SET PSANAME=$PIECE(Y,"^",2)
- SET PSDISP=+$PIECE($GET(^PS(52.6,PSAIEN,0)),"^",2)
- SET PSPOI=$PIECE($GET(^(0)),"^",11)
- LOCK +^PS(52.6,PSAIEN):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF '$TEST
- WRITE !,$CHAR(7),"Another person is editing this additive."
- QUIT
- +2 IF 'PSDISP
- WRITE $CHAR(7),!!?5,"This IV Additive does not point to the Dispense Drug File (#50)",!?5,"it cannot be matched to an Orderable Item!",!
- GOTO EN
- ENTER IF 'PSPOI
- GOTO ADD
- +1 SET PSOINAME=$PIECE($GET(^PS(50.7,PSPOI,0)),"^")
- SET PSOIDOSE=+$PIECE($GET(^(0)),"^",2)
- WRITE !!,"IV ADDITIVE -> ",PSANAME,!," is already matched to:",!,PSOINAME," ",$PIECE($GET(^PS(50.606,PSOIDOSE,0)),"^")
- +2 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to re-match this IV Additive"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF Y'=1
- DO SELIV^PSSSOLIT
- GOTO @$SELECT($GET(PSSJI)&('$GET(PSSIVOUT)):"ENA^PSSVIDRG",1:"EN")
- +3 SET PSDELADD=PSAIEN
- SET PSDELOIT=PSPOI
- SET PSDELFLG=1
- +4 KILL DIE
- SET DA=PSAIEN
- SET DIE="^PS(52.6,"
- SET DR="15////"_"@"
- DO ^DIE
- DO EN^PSSPOIDT(PSPOI)
- DO EN2^PSSHL1(PSPOI,"MUP")
- KILL PSPOI,PSOINAME,PSOIDOSE
- GOTO ADD
- INACT WRITE !
- KILL DIE
- SET PSBEFORE=$PIECE(^PS(50.7,PSPOI,0),"^",4)
- SET PSAFTER=0
- SET PSINORDE=""
- SET DIE="^PS(50.7,"
- SET DR=".04;.05;.06;.07;.08"
- SET DA=PSPOI
- DO ^DIE
- SET PSAFTER=$PIECE(^PS(50.7,PSPOI,0),"^",4)
- KILL DIE
- +1 if PSBEFORE&('PSAFTER)
- SET PSINORDE="D"
- if PSAFTER
- SET PSINORDE="I"
- +2 IF PSINORDE'=""
- DO REST^PSSPOIDT(PSPOI)
- +3 KILL PSBEFORE,PSAFTER,PSINORDE
- SYN WRITE !
- KILL DIC
- if '$DATA(^PS(50.7,PSPOI,2,0))
- SET ^PS(50.7,PSPOI,2,0)="^50.72^0^0"
- SET DIC="^PS(50.7,"_PSPOI_",2,"
- SET DA(1)=PSPOI
- SET DIC(0)="QEAMZL"
- SET DIC("A")="Select SYNONYM: "
- SET DLAYGO=50.7
- DO ^DIC
- KILL DIC
- +1 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
- if '$ORDER(^PS(50.7,PSPOI,2,0))
- KILL ^PS(50.7,PSPOI,2,0)
- if $GET(NEWFLAG)
- QUIT
- if '$GET(PSSSSS)
- DO EN2^PSSHL1(PSPOI,"MUP")
- DO END
- GOTO EN
- +2 WRITE !
- SET DA=+Y
- SET DIE="^PS(50.7,"_PSPOI_",2,"
- SET DA(1)=PSPOI
- SET DR=.01
- DO ^DIE
- KILL DIE
- GOTO SYN
- +3 if $GET(NEWFLAG)
- QUIT
- if '$GET(PSSSSS)
- DO EN2^PSSHL1(PSPOI,"MUP")
- +4 DO END
- GOTO EN
- CHECK 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=VV
- if VV&($PIECE($GET(^(0)),"^",3))&($DATA(^PS(52.6,"AOI",VV)))
- SET ZZXFLAG=VV
- +1 QUIT
- END IF $DATA(PSAIEN)
- LOCK -^PS(52.6,PSAIEN)
- +1 KILL PSDELADD,PSDELFLG,PSDELOIT,PSSSSS
- +2 KILL DA,DIC,DR,DTOUT,LL,QQ,HOLDOI,INFLAG,NEWFLAG,PSAIEN,PSANAME,PSDISP,PSDOSNM,PSDOSPTR,PSND,PSND1,PSND3,PSONEW,PSNDOSE,PSNEWOI,PSOIDOSE,PSOINAME,PSPOI,SCOUNT,SS,SYN,SYN1,VV,PFLAG,PFLAGOI,WW,X,XXX,Y,ZZFLAG,PANS,ZZXFLAG,SYNNAM,VV,VVV,TT,SCLAST
- QUIT
- ADD ;
- +1 KILL PSDOSPTR
- 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))
- WRITE !?3,"*** Dose Form from NDF: ",$PIECE($GET(^PS(50.606,PSDOSPTR,0)),"^")
- 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 EN
- +5 SET PSDOSPTR=+Y
- PASS SET PSDOSNM=$PIECE($GET(^PS(50.606,PSDOSPTR,0)),"^")
- SET PSOIDOSE=PSDOSPTR
- SET XXX=PSANAME
- DO CHECK
- +1 IF $GET(ZZFLAG)
- IF '$GET(ZZXFLAG)
- WRITE $CHAR(7),!!,"There is already an Orderable Item named:",!?5,$PIECE($GET(^PS(50.7,ZZFLAG,0)),"^")," ",$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^"),!
- +2 IF $TEST
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Match to this Orderable Item"
- DO ^DIR
- KILL DIR
- IF Y["^"!($DATA(DTOUT))
- GOTO EN
- +3 IF $GET(ZZFLAG)
- IF '$GET(ZZXFLAG)
- IF $GET(Y)
- WRITE !!,"Matching: ",PSANAME,!," to",!,$PIECE($GET(^PS(50.7,+ZZFLAG,0)),"^")_" "_PSDOSNM
- WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Is this OK"
- DO ^DIR
- SET PANS=Y
- if PANS=1
- GOTO MAT^PSSSUTIL
- if (PANS["^")!($DATA(DTOUT))
- GOTO EN
- +4 IF $GET(ZZXFLAG)
- WRITE $CHAR(7),!!?5,"You must create a new Orderable Item Name for this IV Additive, since a",!?5,"duplicate already exists with another IV Additive matched to it!",!
- XDIR WRITE !!,"Additive Name -> ",$GET(PSANAME),!,"Dose Form -> ",$GET(PSDOSNM),!
- +1 SET X=PSANAME
- DO INPUT
- +2 KILL DIR
- SET DIR(0)="F^3:40"
- SET DIR("A")="Enter Orderable Item Name"
- IF '$GET(ZZXFLAG)
- IF '$GET(INFLAG)
- IF $LENGTH(PSANAME)>2
- IF $LENGTH(PSANAME)<41
- SET DIR("B")=PSANAME
- +3 DO ^DIR
- KILL DIR
- IF Y["^"!(Y="")!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO EN
- +4 SET HOLDOI=X
- +5 DO INPUT
- IF INFLAG
- SET X=PSANAME
- GOTO XDIR
- +6 SET (PFLAG,PFLAGOI)=0
- FOR QQ=0:0
- SET QQ=$ORDER(^PS(50.7,"ADF",X,PSOIDOSE,QQ))
- if 'QQ!(PFLAG)
- QUIT
- IF QQ
- IF $PIECE($GET(^PS(50.7,QQ,0)),"^",3)'=""
- SET PFLAG=1
- SET PFLAGOI=QQ
- +7 IF PFLAG
- IF $DATA(^PS(52.6,"AOI",PFLAGOI))
- WRITE $CHAR(7),!!,?2,"A duplicate Name and Dose Form entry already exists in the Orderable Item",!,?2,"File, with a corresponding matched IV Additive. You must select another name!"
- GOTO XDIR
- +8 IF PFLAG
- IF '$DATA(^PS(52.6,"AOI",PFLAGOI))
- WRITE !!,"Matching: ",PSANAME,!," to",!,$PIECE($GET(^PS(50.7,PFLAGOI,0)),"^")_" "_$GET(PSDOSNM)
- WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Is this OK"
- DO ^DIR
- KILL DIR
- if Y["^"!($DATA(DTOUT))
- GOTO EN
- if Y=0
- GOTO XDIR
- +9 IF PFLAG
- IF '$DATA(^PS(52.6,"AOI",PFLAGOI))
- SET ZZFLAG=PFLAGOI
- GOTO MAT^PSSSUTIL
- NEW ;create new entry in 50.7 and match to it
- +1 WRITE !!,"Matching: ",PSANAME,!," to",!,HOLDOI_" "_$GET(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
- SET X=PSANAME
- 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
- +4 IF Y<1
- WRITE !!?5,"UNABLE TO CREATE ENTRY, TRY AGAIN!",!
- GOTO XDIR
- +5 SET PSNEWOI=+Y
- SET SCOUNT=0
- FOR SS=0:0
- SET SS=$ORDER(^PS(52.6,PSAIEN,3,SS))
- if 'SS
- QUIT
- SET SCOUNT=SCOUNT+1
- SET SYN(SCOUNT)=^(SS,0)
- +6 KILL DIE
- SET DIE="^PS(52.6,"
- SET DA=PSAIEN
- SET DR="15////"_PSNEWOI
- DO ^DIE
- KILL DIE
- +7 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)
- +8 IF SCOUNT
- FOR LL=0:0
- SET LL=$ORDER(^PS(50.7,PSNEWOI,2,LL))
- if 'LL
- QUIT
- SET SYNNAM=$PIECE(^(LL,0),"^")
- SET ^PS(50.7,PSNEWOI,2,"B",SYNNAM,LL)=""
- +9 SET NEWFLAG=1
- SET PSPOI=PSNEWOI
- DO DIR^PSSPOIM3
- IF $GET(PSSDIR)
- WRITE !!?3,"Now editing Orderable Item:",!?3,$PIECE(^PS(50.7,PSNEWOI,0),"^")," ",$PIECE($GET(^PS(50.606,+$PIECE(^(0),"^",2),0)),"^")
- DO INACT
- KILL NEWFLAG
- +10 KILL NEWFLAG,PSSDIR
- +11 DO EN^PSSPOIDT(PSPOI)
- if '$GET(PSSSSS)
- DO EN2^PSSHL1(PSNEWOI,"MAD")
- +12 GOTO EN
- INPUT SET INFLAG=0
- IF X[""""!($ASCII(X)=45)!('(X'?1P.E))!(X?2"z".E)
- WRITE $CHAR(7),!?5,"??",!
- SET INFLAG=1
- +1 QUIT