source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET7.m@ 923

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