111 lines
5.1 KiB
Mathematica
111 lines
5.1 KiB
Mathematica
RMPFET7 ;DDC/KAW-SPECIAL EDIT SUB-ROUTINES [ 06/16/95 3:06 PM ]
|
|
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17**;06/06/01
|
|
ISSUE ;; input: RMPFX,RMPFTYP,RMPFHAT,DFN
|
|
;;output: None
|
|
S NB=12 D AUTH^RMPFET71 G END:$D(RMPFOUT) D PAT^RMPFUTL
|
|
START W @IOF,!?36,"EXISTING ORDER"
|
|
W !,"Patient: ",RMPFNAM,?64,"SSN: ",RMPFSSN
|
|
W ! F I=1:1:80 W "-"
|
|
D ^RMPFDT2 K RMPF S (X,CK)=0 F S X=$O(RMPFO(X)) Q:'X D
|
|
.Q:'$D(^RMPF(791810,RMPFX,101,X,0)) S S0=^(0),SN=$P(S0,U,5)
|
|
.I SN'="",$D(SN(SN)) W $C(7),!!,"*** DUPLICATE SERIAL NUMBERS IN ORDER ***" Q
|
|
.I SN'="" S SN(SN)=""
|
|
.Q:$P(S0,U,15)="C" S Y=$P(S0,U,18)
|
|
.I Y,$D(^RMPF(791810.2,Y,0)) S Y=$P(^(0),U,2) I Y'="","EDS"[Y S CK=CK+1,RMPF(CK)=X
|
|
K SN
|
|
I CK=0 W !!,"*** NO LINE ITEMS TO ISSUE ***",!!,"Enter <RETURN> to continue." D READ G END
|
|
A1 W !!,"Enter <I>ssue or <RETURN> to exit. "
|
|
D READ G END:$D(RMPFOUT)
|
|
A11 I $D(RMPFQUT) W !!,"Enter an <I> to issue line item(s) or <RETURN> to exit." G A1
|
|
G END:Y="" S Y=$E(Y,1) G END:"Ii"'[Y
|
|
I CK=1 S PT=1,RMPFY=RMPF(1) D CAN G END:$D(RMPFOUT) G START
|
|
ASK W !!,"Issue ",CK," line items? YES// " D READ G END:$D(RMPFOUT)
|
|
ASK1 I $D(RMPFQUT) W !!,"Enter a <Y> or <RETURN> to issue ",CK," line items",!?5,"an <N> to exit." G ASK
|
|
S:Y="" Y="Y" S Y=$E(Y,1)
|
|
I "YyNn"'[Y S RMPFQUT="" G ASK1
|
|
G SEL:"Nn"[Y S PT=0
|
|
LOOP S PT=$O(RMPF(PT)) G LOOPE:'PT
|
|
S RMPFY=RMPF(PT) D CAN G LOOPE:$D(RMPFOUT),LOOP
|
|
LOOPE G START
|
|
SEL W !!,"Select number of item to issue: "
|
|
D READ G END:$D(RMPFOUT)
|
|
SEL1 I $D(RMPFQUT) W !!,"Enter the number to the left of the item you wish to issue",!,"or <RETURN> to continue." G SEL
|
|
G END:Y="" I '$D(RMPFMD(Y)) S RMPFQUT="" G SEL1
|
|
S (DA,RMPFY)=RMPFMD(Y),PT=Y D CAN G END:$D(RMPFOUT)
|
|
G START
|
|
CAN ;; input: RMPFX,RMPFY,PT,CK,RMPFMD,RMPFTYP
|
|
;;output: None
|
|
I $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,15)="C" W $C(7),!!,"*** THIS LINE ITEM HAS BEEN CANCELED ***" Q
|
|
S X=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18) Q:'X
|
|
Q:'$D(^RMPF(791810.2,X,0)) S RMPFSTO=$P(^(0),U,2)
|
|
I "ED"[RMPFSTO D CLEAR^RMPFET61 Q:'$D(RMPFSTO)
|
|
I "DES"'[RMPFSTO W $C(7),!!,"*** LINE ITEMS WITH THIS STATUS CANNOT BE ISSUED ***" H 1 K RMPFY Q
|
|
I '$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,9) W $C(7),!!,"*** THIS LINE ITEM HAS NOT BEEN CERTIFIED *** " H 1 K RMPFY Q
|
|
D ^RMPFET71 Q:$D(RMPFOUT)
|
|
EXIT1 K X,RMPFSTO,DIE,DA,DR Q
|
|
END K %,%DT,%Y,CK,CX,D,D0,D1,DA,DI,DIC,DIE,DQ,DR,RMPFMD,RMPFO,RMPFDOB,NB
|
|
K RMPFNAM,RMPFSSN,PT,SN,Y,RMPFLA,RMPFSTO,S,X,RMPFY,RMPFDOD,RMPF,S0,CM,K Q
|
|
COMPON ;;Add/Edit a component
|
|
;; input: RMPFX,RMPFY,RMPFADD (opt.),RMPFRE (opt.)
|
|
;;output: RMPFRE
|
|
D ARRAY2^RMPFDT2 S:'$D(RMPFRE) RMPFRE=""
|
|
S IT=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1) Q:IT=1
|
|
S DIC("S")="I $D(^RMPF(791811,IT,101,""B"",Y))"
|
|
COM1 ;W !,"SELECT COMPONENT: "
|
|
D READ1 G COME:$D(RMPFOUT)
|
|
COM11 ;I $D(RMPFQUT) S X="?" G COM12
|
|
G COME:Y=""
|
|
S X=Y
|
|
COM12 I '$D(^RMPF(791810,RMPFX,101,RMPFY,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY,102,0)="^791810.101102P"
|
|
;S DIC=791811.2,DIC(0)="EQM" D ^DIC K DIC G COMPON:Y=-1
|
|
S IX=0 F I=1:1 S IX=$O(RMPFC(IX)) Q:'IX I $P(RMPFC(IX),U,1)=+Y D DEL G COMPON
|
|
D NEW S X=+Y,DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,"
|
|
S DA(2)=RMPFX,DA(1)=RMPFY,DIC(0)="LN",DLAYGO=791810
|
|
K DD,DO D FILE^DICN I Y=-1 W $C(7),!!,"*** COMPONENT NOT ADDED ***" H 2 G COMPON
|
|
S RMPFZ=+Y,SX=^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0)
|
|
S $P(SX,U,3)=$S('$D(RMPFADD):"O",1:"A"),$P(SX,U,4)=+Y
|
|
G COM2:'$D(RMPFADD) S $P(SX,U,5)=DUZ,$P(SX,U,7)=RMPFRE
|
|
S X="NOW",%DT="T" D ^%DT S $P(SX,U,6)=Y
|
|
COM2 S ^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0)=SX G COMPON
|
|
COME K IT,DIC,X,Y,IX,I,RMPFC,DA,RMPFZ,SX,RMPFADD,%,%DT,DIR
|
|
K DISYS,DLAYGO,DIK,M,RMPFQUT Q
|
|
DEL S CM=$P(^RMPF(791811.2,+Y,0),U,1)
|
|
W !!,"The component you chose (",CM,") has already been added to this aid."
|
|
W !!,"Do you wish to delete the ",CM,"? NO// " D READ Q:$D(RMPFOUT)
|
|
DEL1 I $D(RMPFQUT) W !!,"Enter a <Y> to delete the component",!?6,"a <N> or <RETURN> to keep the component on order." G DEL
|
|
S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G DEL1
|
|
Q:"Nn"[Y
|
|
S DIK="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,",DA=IX,DA(1)=RMPFY,DA(2)=RMPFX
|
|
D ^DIK
|
|
Q
|
|
SECOND Q:'$D(RMPFX) Q:'$D(RMPFY)
|
|
Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S SZ=^(0)
|
|
S SU=$P(SZ,U,1) I SU,$D(^RMPF(791811,SU,0)),$P(^(0),U,7) D
|
|
.I $D(^RMPF(791810,RMPFX,101,RMPFY,2)) S X=$P(^(2),U,3) I X,$D(^RMPF(791811.3,X,0)) S DIC("B")=$P(^(0),U,1)
|
|
.S DIC=791811.3,DIC("A")="SECOND BATTERY TYPE: "
|
|
.S DIC(0)="AEQM"
|
|
.D ^DIC I Y'=-1 S $P(^RMPF(791810,RMPFX,101,RMPFY,2),U,3)=+Y
|
|
.Q
|
|
K SU,SZ,X,Y,DIC Q
|
|
READ K RMPFOUT,RMPFQUT
|
|
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
|
|
I Y?1"^".E S (RMPFOUT,Y)="" Q
|
|
S:Y?1"?".E (RMPFQUT,Y)=""
|
|
Q
|
|
READ1 K DIR,RMPFOUT,RMPFQUT
|
|
S DIR(0)="PO^791811.2:EMZ"
|
|
S DIR("A")="SELECT COMPONENT"
|
|
S:$P($G(^RMPF(791810.1,RMPFTYP,0)),U,2)="C" DIR("S")="I $P(^RMPF(791811.2,Y,0),U,4)=1"
|
|
S:$P($G(^RMPF(791810.1,RMPFTYP,0)),U,2)="X" DIR("S")="I $P(^RMPF(791811.2,Y,0),U,5)'=1"
|
|
D ^DIR
|
|
S:$E(X,1)="^" (RMPFOUT,Y)=""
|
|
S:X="" Y=""
|
|
Q
|
|
NEW N DIC,DA,DR,DO,DD,DQ,D0,DP Q
|
|
CHECK ;; input: RMPFTYP
|
|
;;output: DIC("S"),RMPF
|
|
K DIC("S") Q:'$D(RMPFTYP) Q:RMPFTYP=15 K RM S K=0
|
|
F S K=$O(^RMPF(791810.1,RMPFTYP,103,K)) Q:'K I $D(^(K,0)) S RMPF($E($P(^(0),U,1),1))=""
|
|
S DIC("S")="S Z1=$E(X,1) I $D(RMPF(Z1))"
|
|
CHECKE Q
|