- RMPFEA2 ;DDC/KAW-APPROVE ORDERS [ 06/20/97 10:39 AM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**3**;MAY 30, 1995
- APPROV ;; input: RMPFX,RMPFHAT
- ;;output: None
- S X=$P(^RMPF(791810,RMPFX,0),U,3) G END:'X
- S FX="PS" D
- .I RMPFHAT="I"!(RMPFHAT="X") S FX=FX_"F" Q
- .D ARRAY^RMPFDT2 S XX=0
- .F S XX=$O(RMPFO(XX)) Q:'XX I $D(^RMPF(791810,RMPFX,101,XX,0)),$P(^(0),U,19)["A",$P(^(0),U,20) S FX=FX_"F" Q
- G END:'$D(^RMPF(791810.2,X,0)) S ST=$P(^(0),U,2) G END:FX'[ST
- I RMPFHAT="I" S X=$P(^RMPF(791810,RMPFX,0),U,3) D G END:$D(X),APP
- .I $P($G(^RMPF(791810.2,X,0)),U,5)'="E"&($P(^(0),U,2)'="C") Q
- .D ARRAY^RMPFDT2 S X=0
- .F S X=$O(RMPFO(X)) Q:'X I $P($G(^RMPF(791810,RMPFX,101,X,0)),U,20) Q
- .I X K X
- AP S X=$P(RMPFSYS,U,7) S:X="" X="S" G APP:X="N"
- I RMPFMENU=10,X="A" G APP
- I X="A",$D(^RMPF(791813,RMPFSTAN,101,DUZ,0)),$P(^(0),U,3) G APP
- I '$D(^XUSEC("RMPF SUPERVISOR",DUZ)) Q
- APPROV1 S X=$P(^RMPF(791810,RMPFX,0),U,3) G END:'X
- G END:'$D(^RMPF(791810.2,X,0)) S ST=$P(^(0),U,2) G END:"PSF"'[ST
- D ARRAY^RMPFDT2 K ED
- I X="S" D G END:'$D(ED),APP
- .S O=0
- .F S O=$O(RMPFO(O)) Q:'O I $P(^RMPF(791810,RMPFX,101,O,0),U,20) S ED="" Q
- I RMPFHAT'="U" S Y=0 F S Y=$O(RMPFO(Y)) Q:'Y I $D(^RMPF(791810,RMPFX,101,Y,0)),$P(^(0),U,19)="C",$P(^(0),U,20) G APP
- Q:"BPSF"'[ST
- APP W !!,"APPROVE this order? YES// " D READ Q:$D(RMPFOUT)
- APP1 I $D(RMPFQUT) W !!,"Enter <Y> to approve the order and place it in a batch or <N> to continue." G APP
- S:Y="" Y="Y" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G APP1
- G END:"Nn"[Y
- SET ;; input: RMPFX,RMPFHAT
- ;;output: None
- S FL=0 I RMPFHAT="Y"!(RMPFHAT="K") D BATCH G SETX
- D ARRAY^RMPFDT2 S FY=0
- ST1 S FY=$O(RMPFO(FY)) G SETX:'FY
- G ST1:'$D(^RMPF(791810,RMPFX,101,FY,0)) S S0=^(0)
- S X=$P(S0,U,18),Y=$P(S0,U,20) G ST1:'Y
- G ST1:X="" S X=$P($G(^RMPF(791810.2,X,0)),U,2)
- I X="C",$P(^RMPF(791810,RMPFX,101,FY,0),U,20),$P(^(0),U,19)["A" G ST2
- G ST1:"PSNAF"'[X
- I X="A",Y G ST2
- I X="S",'$P($G(^RMPF(791810,RMPFX,101,FY,90)),U,9),$P(^(0),U,19)'["A" G ST1
- I X="S",$P(S0,U,19)["I" G ST1:$P(S0,U,2)="",ST1:$P(S0,U,5)="",ST1:$P(S0,U,8)=""
- ST2 S FL=1 D SET1 G ST1
- SETX I 'FL G SETE:RMPFHAT'="K"&(RMPFHAT'="Y")
- S %DT="T",X="NOW" D ^%DT S DIE="^RMPF(791810,",DA=RMPFX
- S DR=".03///APPROVED;.06////"_Y_";.1////"_DUZ_";.11////"_Y D ^DIE
- S RMPFCAT=$P($G(^RMPF(791810,RMPFX,10)),U,5)
- I RMPFCAT'="","PE"[RMPFCAT D EMER^RMPFEA3
- D FORM:RMPFHAT="S"
- I RMPFHAT="I" D ARRAY^RMPFDT2 S X=0 F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,0)),$P(^(0),U,19)["I" D FORM Q
- SETE K FL,RMPFBT,RMPFCAT,X,Y,S0,%DT,D,D0,DA,DI,DIC,DIE,DQ,DR,FY,RMPFO Q
- SET1 ;;Set to approved and place in a batch when line item known
- ;; input: FY,PT,RMPFX
- ;;output: RMPFBT
- S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=FY
- S X="NOW",%DT="T" D ^%DT
- S X=$S($P(^RMPF(791810,RMPFX,101,FY,0),U,15)'="C":"APPROVED",1:"CANCELED")
- S DR=".18///"_X_";.17////"_Y_";.2////0" D ^DIE
- K DIE,DI,DR,D0,D,%,%DT,DISYS,DQ,I,L
- BATCH ;;Find open batch
- S RMPFBT=0,MN=$O(^RMPF(791810.5,"C",RMPFMENU,0))
- F I=1:1 S RMPFBT=$O(^RMPF(791812,"C",1,RMPFBT)) Q:'RMPFBT S S1=$G(^RMPF(791812,RMPFBT,0)) I $P(S1,U,8)=RMPFSTAP S X=$P(S1,U,9) S:X="" X=0 I X=MN Q
- G TRANS:RMPFBT S X="NOW",%DT="T" D ^%DT S X=Y
- F I=1:1 Q:'$D(^RMPF(791812,"B",X)) S X=X+.00001
- S DIC="^RMPF(791812,",DIC(0)="L",DLAYGO=791812
- S DIC("DR")=".02////1;.08////"_RMPFSTAP_";.09////"_$O(^RMPF(791810.5,"C",RMPFMENU,0))
- K DD,DO D FILE^DICN K DIC
- I Y=-1 W !!,$C(7),"*** UNABLE TO ADD A NEW BATCH - CONTACT IRMS ***" G END
- S RMPFBT=+Y I $P(RMPFSYS,U,3)="A" D ^RMPFEA3
- TRANS ;;Add order to a batch
- S:'$D(^RMPF(791812,RMPFBT,101,0)) ^RMPF(791812,RMPFBT,101,0)="^791812.0101PA^^" L ^RMPF(791812,RMPFBT)
- G BATCHE:'$D(^RMPF(791810,RMPFX,0))
- S PT=$O(^RMPF(791812,RMPFBT,101,"B",RMPFX,0))
- I PT,$D(^RMPF(791812,RMPFBT,101,PT,0)),$P(^(0),U,2) D G BATCHE
- .S $P(^(0),U,2,4)="",$P(^RMPF(791810,RMPFX,10),U,2)=""
- .S X=$P(^RMPF(791812,RMPFBT,0),U,4),X=X+1,$P(^(0),U,4)=X
- I PT,$D(^RMPF(791812,RMPFBT,101,PT,0)) G BATCHE
- S X=RMPFX,DIC="^RMPF(791812,"_RMPFBT_",101,",DA(1)=RMPFBT,DIC(0)="L"
- S DLAYGO=791812 K DD,DO D ^DICN
- I Y=-1 W !!,$C(7),"*** NOT ADDED - CONTACT IRMS ***" G BATCHE
- COUNT S X=$P(^RMPF(791812,RMPFBT,0),U,4),X=X+1,$P(^(0),U,4)=X
- W !!?20,"*** ADDED TO TRANSMISSION BATCH *** " H 1
- S DIE="^RMPF(791810,",DA=RMPFX,DR=".12////"_RMPFBT D ^DIE
- BATCHE L K DIC,DA,DLAYGO,PT,X,Y,S1,I,%,DIE,D0,DQ,D,DI,DR,%DT,%X,%Y Q
- END K ED,MN,X,FX,RMPFBT,FY,O,S,Y,XX Q
- K RMPFLIS,RMPFLISD,RMPFSD,RMPFY,S0,S3 Q
- FORM W !!,"Print Form 10-2477a? NO// " D READ Q:$D(RMPFOUT)
- FORM1 I $D(RMPFQUT) W !!,"Enter a <Y> to print a 2477a, <N> or <RETURN> to exit." G FORM
- S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G FORM1
- I "Yy"[Y S RMPFRTN="^RMPFQP3" D QUE^RMPFQP
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFEA2 4930 printed Jan 18, 2025@03:37:12 Page 2
- RMPFEA2 ;DDC/KAW-APPROVE ORDERS [ 06/20/97 10:39 AM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**3**;MAY 30, 1995
- APPROV ;; input: RMPFX,RMPFHAT
- +1 ;;output: None
- +2 SET X=$PIECE(^RMPF(791810,RMPFX,0),U,3)
- if 'X
- GOTO END
- +3 SET FX="PS"
- Begin DoDot:1
- +4 IF RMPFHAT="I"!(RMPFHAT="X")
- SET FX=FX_"F"
- QUIT
- +5 DO ARRAY^RMPFDT2
- SET XX=0
- +6 FOR
- SET XX=$ORDER(RMPFO(XX))
- if 'XX
- QUIT
- IF $DATA(^RMPF(791810,RMPFX,101,XX,0))
- IF $PIECE(^(0),U,19)["A"
- IF $PIECE(^(0),U,20)
- SET FX=FX_"F"
- QUIT
- End DoDot:1
- +7 if '$DATA(^RMPF(791810.2,X,0))
- GOTO END
- SET ST=$PIECE(^(0),U,2)
- if FX'[ST
- GOTO END
- +8 IF RMPFHAT="I"
- SET X=$PIECE(^RMPF(791810,RMPFX,0),U,3)
- Begin DoDot:1
- +9 IF $PIECE($GET(^RMPF(791810.2,X,0)),U,5)'="E"&($PIECE(^(0),U,2)'="C")
- QUIT
- +10 DO ARRAY^RMPFDT2
- SET X=0
- +11 FOR
- SET X=$ORDER(RMPFO(X))
- if 'X
- QUIT
- IF $PIECE($GET(^RMPF(791810,RMPFX,101,X,0)),U,20)
- QUIT
- +12 IF X
- KILL X
- End DoDot:1
- if $DATA(X)
- GOTO END
- GOTO APP
- AP SET X=$PIECE(RMPFSYS,U,7)
- if X=""
- SET X="S"
- if X="N"
- GOTO APP
- +1 IF RMPFMENU=10
- IF X="A"
- GOTO APP
- +2 IF X="A"
- IF $DATA(^RMPF(791813,RMPFSTAN,101,DUZ,0))
- IF $PIECE(^(0),U,3)
- GOTO APP
- +3 IF '$DATA(^XUSEC("RMPF SUPERVISOR",DUZ))
- QUIT
- APPROV1 SET X=$PIECE(^RMPF(791810,RMPFX,0),U,3)
- if 'X
- GOTO END
- +1 if '$DATA(^RMPF(791810.2,X,0))
- GOTO END
- SET ST=$PIECE(^(0),U,2)
- if "PSF"'[ST
- GOTO END
- +2 DO ARRAY^RMPFDT2
- KILL ED
- +3 IF X="S"
- Begin DoDot:1
- +4 SET O=0
- +5 FOR
- SET O=$ORDER(RMPFO(O))
- if 'O
- QUIT
- IF $PIECE(^RMPF(791810,RMPFX,101,O,0),U,20)
- SET ED=""
- QUIT
- End DoDot:1
- if '$DATA(ED)
- GOTO END
- GOTO APP
- +6 IF RMPFHAT'="U"
- SET Y=0
- FOR
- SET Y=$ORDER(RMPFO(Y))
- if 'Y
- QUIT
- IF $DATA(^RMPF(791810,RMPFX,101,Y,0))
- IF $PIECE(^(0),U,19)="C"
- IF $PIECE(^(0),U,20)
- GOTO APP
- +7 if "BPSF"'[ST
- QUIT
- APP WRITE !!,"APPROVE this order? YES// "
- DO READ
- if $DATA(RMPFOUT)
- QUIT
- APP1 IF $DATA(RMPFQUT)
- WRITE !!,"Enter <Y> to approve the order and place it in a batch or <N> to continue."
- GOTO APP
- +1 if Y=""
- SET Y="Y"
- SET Y=$EXTRACT(Y,1)
- IF "YyNn"'[Y
- SET RMPFQUT=""
- GOTO APP1
- +2 if "Nn"[Y
- GOTO END
- SET ;; input: RMPFX,RMPFHAT
- +1 ;;output: None
- +2 SET FL=0
- IF RMPFHAT="Y"!(RMPFHAT="K")
- DO BATCH
- GOTO SETX
- +3 DO ARRAY^RMPFDT2
- SET FY=0
- ST1 SET FY=$ORDER(RMPFO(FY))
- if 'FY
- GOTO SETX
- +1 if '$DATA(^RMPF(791810,RMPFX,101,FY,0))
- GOTO ST1
- SET S0=^(0)
- +2 SET X=$PIECE(S0,U,18)
- SET Y=$PIECE(S0,U,20)
- if 'Y
- GOTO ST1
- +3 if X=""
- GOTO ST1
- SET X=$PIECE($GET(^RMPF(791810.2,X,0)),U,2)
- +4 IF X="C"
- IF $PIECE(^RMPF(791810,RMPFX,101,FY,0),U,20)
- IF $PIECE(^(0),U,19)["A"
- GOTO ST2
- +5 if "PSNAF"'[X
- GOTO ST1
- +6 IF X="A"
- IF Y
- GOTO ST2
- +7 IF X="S"
- IF '$PIECE($GET(^RMPF(791810,RMPFX,101,FY,90)),U,9)
- IF $PIECE(^(0),U,19)'["A"
- GOTO ST1
- +8 IF X="S"
- IF $PIECE(S0,U,19)["I"
- if $PIECE(S0,U,2)=""
- GOTO ST1
- if $PIECE(S0,U,5)=""
- GOTO ST1
- if $PIECE(S0,U,8)=""
- GOTO ST1
- ST2 SET FL=1
- DO SET1
- GOTO ST1
- SETX IF 'FL
- if RMPFHAT'="K"&(RMPFHAT'="Y")
- GOTO SETE
- +1 SET %DT="T"
- SET X="NOW"
- DO ^%DT
- SET DIE="^RMPF(791810,"
- SET DA=RMPFX
- +2 SET DR=".03///APPROVED;.06////"_Y_";.1////"_DUZ_";.11////"_Y
- DO ^DIE
- +3 SET RMPFCAT=$PIECE($GET(^RMPF(791810,RMPFX,10)),U,5)
- +4 IF RMPFCAT'=""
- IF "PE"[RMPFCAT
- DO EMER^RMPFEA3
- +5 if RMPFHAT="S"
- DO FORM
- +6 IF RMPFHAT="I"
- DO ARRAY^RMPFDT2
- SET X=0
- FOR
- SET X=$ORDER(RMPFO(X))
- if 'X
- QUIT
- IF $DATA(^RMPF(791810,RMPFX,101,X,0))
- IF $PIECE(^(0),U,19)["I"
- DO FORM
- QUIT
- SETE KILL FL,RMPFBT,RMPFCAT,X,Y,S0,%DT,D,D0,DA,DI,DIC,DIE,DQ,DR,FY,RMPFO
- QUIT
- SET1 ;;Set to approved and place in a batch when line item known
- +1 ;; input: FY,PT,RMPFX
- +2 ;;output: RMPFBT
- +3 SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA(1)=RMPFX
- SET DA=FY
- +4 SET X="NOW"
- SET %DT="T"
- DO ^%DT
- +5 SET X=$SELECT($PIECE(^RMPF(791810,RMPFX,101,FY,0),U,15)'="C":"APPROVED",1:"CANCELED")
- +6 SET DR=".18///"_X_";.17////"_Y_";.2////0"
- DO ^DIE
- +7 KILL DIE,DI,DR,D0,D,%,%DT,DISYS,DQ,I,L
- BATCH ;;Find open batch
- +1 SET RMPFBT=0
- SET MN=$ORDER(^RMPF(791810.5,"C",RMPFMENU,0))
- +2 FOR I=1:1
- SET RMPFBT=$ORDER(^RMPF(791812,"C",1,RMPFBT))
- if 'RMPFBT
- QUIT
- SET S1=$GET(^RMPF(791812,RMPFBT,0))
- IF $PIECE(S1,U,8)=RMPFSTAP
- SET X=$PIECE(S1,U,9)
- if X=""
- SET X=0
- IF X=MN
- QUIT
- +3 if RMPFBT
- GOTO TRANS
- SET X="NOW"
- SET %DT="T"
- DO ^%DT
- SET X=Y
- +4 FOR I=1:1
- if '$DATA(^RMPF(791812,"B",X))
- QUIT
- SET X=X+.00001
- +5 SET DIC="^RMPF(791812,"
- SET DIC(0)="L"
- SET DLAYGO=791812
- +6 SET DIC("DR")=".02////1;.08////"_RMPFSTAP_";.09////"_$ORDER(^RMPF(791810.5,"C",RMPFMENU,0))
- +7 KILL DD,DO
- DO FILE^DICN
- KILL DIC
- +8 IF Y=-1
- WRITE !!,$CHAR(7),"*** UNABLE TO ADD A NEW BATCH - CONTACT IRMS ***"
- GOTO END
- +9 SET RMPFBT=+Y
- IF $PIECE(RMPFSYS,U,3)="A"
- DO ^RMPFEA3
- TRANS ;;Add order to a batch
- +1 if '$DATA(^RMPF(791812,RMPFBT,101,0))
- SET ^RMPF(791812,RMPFBT,101,0)="^791812.0101PA^^"
- LOCK ^RMPF(791812,RMPFBT)
- +2 if '$DATA(^RMPF(791810,RMPFX,0))
- GOTO BATCHE
- +3 SET PT=$ORDER(^RMPF(791812,RMPFBT,101,"B",RMPFX,0))
- +4 IF PT
- IF $DATA(^RMPF(791812,RMPFBT,101,PT,0))
- IF $PIECE(^(0),U,2)
- Begin DoDot:1
- +5 SET $PIECE(^(0),U,2,4)=""
- SET $PIECE(^RMPF(791810,RMPFX,10),U,2)=""
- +6 SET X=$PIECE(^RMPF(791812,RMPFBT,0),U,4)
- SET X=X+1
- SET $PIECE(^(0),U,4)=X
- End DoDot:1
- GOTO BATCHE
- +7 IF PT
- IF $DATA(^RMPF(791812,RMPFBT,101,PT,0))
- GOTO BATCHE
- +8 SET X=RMPFX
- SET DIC="^RMPF(791812,"_RMPFBT_",101,"
- SET DA(1)=RMPFBT
- SET DIC(0)="L"
- +9 SET DLAYGO=791812
- KILL DD,DO
- DO ^DICN
- +10 IF Y=-1
- WRITE !!,$CHAR(7),"*** NOT ADDED - CONTACT IRMS ***"
- GOTO BATCHE
- COUNT SET X=$PIECE(^RMPF(791812,RMPFBT,0),U,4)
- SET X=X+1
- SET $PIECE(^(0),U,4)=X
- +1 WRITE !!?20,"*** ADDED TO TRANSMISSION BATCH *** "
- HANG 1
- +2 SET DIE="^RMPF(791810,"
- SET DA=RMPFX
- SET DR=".12////"_RMPFBT
- DO ^DIE
- BATCHE LOCK
- KILL DIC,DA,DLAYGO,PT,X,Y,S1,I,%,DIE,D0,DQ,D,DI,DR,%DT,%X,%Y
- QUIT
- END KILL ED,MN,X,FX,RMPFBT,FY,O,S,Y,XX
- QUIT
- +1 KILL RMPFLIS,RMPFLISD,RMPFSD,RMPFY,S0,S3
- QUIT
- FORM WRITE !!,"Print Form 10-2477a? NO// "
- DO READ
- if $DATA(RMPFOUT)
- QUIT
- FORM1 IF $DATA(RMPFQUT)
- WRITE !!,"Enter a <Y> to print a 2477a, <N> or <RETURN> to exit."
- GOTO FORM
- +1 if Y=""
- SET Y="N"
- SET Y=$EXTRACT(Y,1)
- IF "YyNn"'[Y
- SET RMPFQUT=""
- GOTO FORM1
- +2 IF "Yy"[Y
- SET RMPFRTN="^RMPFQP3"
- DO QUE^RMPFQP
- +3 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