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