- RMPFET71 ;DDC/KAW-CONTINUATION OF RMPFT7 [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- SET ;;Set line item issue information
- ;; input: RMPFX,RMPFMD,RMPFTYP,PT,CK
- ;;output: None
- G PRIOR:CK=1
- W !!,"Issue item number ",PT," ? YES// " D READ
- G SETE:$D(RMPFOUT)!$D(RMPFQUT)
- I Y=""!("Yy"[$E(Y,1)) S (DA,RMPFY)=RMPFMD(PT) G PRIOR
- K RMPFY Q
- PRIOR D PRIOR^RMPFET61
- S X="NOW",%DT="T" D ^%DT S TD=Y
- S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
- S AP=$P(S0,U,20) I 'AP S RMPFLA="I" G S1
- S RMPFLA=$P(S0,U,19) I RMPFLA="" S RMPFLA="I" G S1
- S RMPFLA=$S(RMPFLA="O":"I",RMPFLA'["I":RMPFLA_"I",1:"I")
- S1 W !! S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
- S DR=$S($D(^RMPF(791810.1,5,1)):^RMPF(791810.1,5,1),1:"")
- S DR=$S(DR'="":DR_";10.01",1:10.01)
- D ^DIE S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
- I $P(S0,U,5)="" W $C(7),!!,"*** SERIAL NUMBER REQUIRED ***" G SETE
- I $P(S0,U,2)="" W $C(7),!!,"*** BATTERY REQUIRED ***" G SETE
- I $P(S0,U,8)'?7N.E W $C(7),!!,"*** VALID ISSUE DATE REQUIRED ***" G SETE
- D SUB S DIE="^RMPF(791810,"_RMPFX_",101,",DA=RMPFY,DA(1)=RMPFX
- S DR=".17////"_TD_";.19////"_RMPFLA_";.2////1" D ^DIE
- K:$D(PT) RMPFMD(PT) D ^RMPFET61 K RMPFSTR0,RMPFSTR2,RMPFSTR3
- S DIE="^RMPF(791810,",DA=RMPFX,DR=10.01 D ^DIE
- SETE K X,Y,Z,TD,AP,LA,DIE,D,D0,DI,DIC,DQ,DA,DR,RMPFLA,RMPFY,S0,RD,%,%T Q
- SUB ;;Check for delay in hearing aid issue
- ;; input: RMPFX,RMPFY,S0
- ;;output: None
- S RD=$P($G(^RMPF(791810,RMPFX,10)),U,4) Q:'RD
- S X=$P(S0,U,8),Z=40 G SUBE:'X D PASTWKDY^RMPFET0
- G SUBE:RD'<Y S DR=90.14,DIE="^RMPF(791810,"_RMPFX_",101,",DA=RMPFY,DA(1)=RMPFX D ^DIE
- S Y=$P(^RMPF(791810,RMPFX,101,RMPFY,90),U,14)
- I Y,$D(^RMPF(791810.6,Y,0)) S X=$P(^(0),U,1) G SUBE:X'="OTHER"
- I Y S DR=90.15 D ^DIE G SUBE:$P(^RMPF(791810,RMPFX,101,RMPFY,90),U,15)'=""
- W $C(7),!!,"*** A REASON FOR DELAY MUST BE ENTERED ***" K RD
- SUBE G SUB:'$D(RD) K X,Y,Z,RD,DIE,DR,DA,D0,DQ,DI,DIC,%T,%Y,D,DIZ,DISYS,% 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
- AUTH ;;Check user for authorization to certify or issue
- ;; input: NB
- ;;output: RMPFOUT
- S X=$P(RMPFSYS,U,NB) G AUTHE:'X
- I X=1,$D(^RMPF(791813,RMPFSTAN,101,DUZ,0)) G AUTHE
- I $D(^XUSEC("RMPF SUPERVISOR",DUZ)) G AUTHE
- W $C(7),!!,"*** YOU HAVE NOT BEEN AUTHORIZED TO ",$S(NB=11:"CERTIFY ORDERS",1:"ISSUE CUSTOM AIDS")," ***" S RMPFOUT=""
- AUTHE K X Q
- IU ;;Check to see if user is an audiologist
- Q:'$P(RMPFSYS,U,12)
- I $P(RMPFSYS,U,12)=1,$D(^RMPF(791813,RMPFSTAN,101,+Y,0)) G IUE
- I $P(RMPFSYS,U,12)=2,$D(^XUSEC("RMPF SUPERVISOR",+Y)) G IUE
- W $C(7),!!,"*** ISSUING USER MUST BE AN AUDIOLOGIST - SEE YOUR ADPAC ***" K X,Y
- IUE Q
- STOCK ;;Check for issue delay in stock hearing aids
- ;; input: RMPFX,RMPFY
- ;;output: None
- N DQ,DP,DC,DI,DL
- S S0=^RMPF(791810,RMPFX,101,RMPFY,0) D SUB
- S X=$P(^RMPF(791810,RMPFX,0),U,8),DA=RMPFY,DA(1)=RMPFX
- S DIE="^RMPF(791810,"_RMPFX_",101,",DR="90.12////"_X D ^DIE
- K DIE,DA,DR,DI,D0,D,DIC,DQ,X,S0 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET71 3052 printed Feb 19, 2025@00:02:55 Page 2
- RMPFET71 ;DDC/KAW-CONTINUATION OF RMPFT7 [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- SET ;;Set line item issue information
- +1 ;; input: RMPFX,RMPFMD,RMPFTYP,PT,CK
- +2 ;;output: None
- +3 if CK=1
- GOTO PRIOR
- +4 WRITE !!,"Issue item number ",PT," ? YES// "
- DO READ
- +5 if $DATA(RMPFOUT)!$DATA(RMPFQUT)
- GOTO SETE
- +6 IF Y=""!("Yy"[$EXTRACT(Y,1))
- SET (DA,RMPFY)=RMPFMD(PT)
- GOTO PRIOR
- +7 KILL RMPFY
- QUIT
- PRIOR DO PRIOR^RMPFET61
- +1 SET X="NOW"
- SET %DT="T"
- DO ^%DT
- SET TD=Y
- +2 SET S0=^RMPF(791810,RMPFX,101,RMPFY,0)
- +3 SET AP=$PIECE(S0,U,20)
- IF 'AP
- SET RMPFLA="I"
- GOTO S1
- +4 SET RMPFLA=$PIECE(S0,U,19)
- IF RMPFLA=""
- SET RMPFLA="I"
- GOTO S1
- +5 SET RMPFLA=$SELECT(RMPFLA="O":"I",RMPFLA'["I":RMPFLA_"I",1:"I")
- S1 WRITE !!
- SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA(1)=RMPFX
- SET DA=RMPFY
- +1 SET DR=$SELECT($DATA(^RMPF(791810.1,5,1)):^RMPF(791810.1,5,1),1:"")
- +2 SET DR=$SELECT(DR'="":DR_";10.01",1:10.01)
- +3 DO ^DIE
- SET S0=^RMPF(791810,RMPFX,101,RMPFY,0)
- +4 IF $PIECE(S0,U,5)=""
- WRITE $CHAR(7),!!,"*** SERIAL NUMBER REQUIRED ***"
- GOTO SETE
- +5 IF $PIECE(S0,U,2)=""
- WRITE $CHAR(7),!!,"*** BATTERY REQUIRED ***"
- GOTO SETE
- +6 IF $PIECE(S0,U,8)'?7N.E
- WRITE $CHAR(7),!!,"*** VALID ISSUE DATE REQUIRED ***"
- GOTO SETE
- +7 DO SUB
- SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA=RMPFY
- SET DA(1)=RMPFX
- +8 SET DR=".17////"_TD_";.19////"_RMPFLA_";.2////1"
- DO ^DIE
- +9 if $DATA(PT)
- KILL RMPFMD(PT)
- DO ^RMPFET61
- KILL RMPFSTR0,RMPFSTR2,RMPFSTR3
- +10 SET DIE="^RMPF(791810,"
- SET DA=RMPFX
- SET DR=10.01
- DO ^DIE
- SETE KILL X,Y,Z,TD,AP,LA,DIE,D,D0,DI,DIC,DQ,DA,DR,RMPFLA,RMPFY,S0,RD,%,%T
- QUIT
- SUB ;;Check for delay in hearing aid issue
- +1 ;; input: RMPFX,RMPFY,S0
- +2 ;;output: None
- +3 SET RD=$PIECE($GET(^RMPF(791810,RMPFX,10)),U,4)
- if 'RD
- QUIT
- +4 SET X=$PIECE(S0,U,8)
- SET Z=40
- if 'X
- GOTO SUBE
- DO PASTWKDY^RMPFET0
- +5 if RD'<Y
- GOTO SUBE
- SET DR=90.14
- SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA=RMPFY
- SET DA(1)=RMPFX
- DO ^DIE
- +6 SET Y=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,90),U,14)
- +7 IF Y
- IF $DATA(^RMPF(791810.6,Y,0))
- SET X=$PIECE(^(0),U,1)
- if X'="OTHER"
- GOTO SUBE
- +8 IF Y
- SET DR=90.15
- DO ^DIE
- if $PIECE(^RMPF(791810,RMPFX,101,RMPFY,90),U,15)'=""
- GOTO SUBE
- +9 WRITE $CHAR(7),!!,"*** A REASON FOR DELAY MUST BE ENTERED ***"
- KILL RD
- SUBE if '$DATA(RD)
- GOTO SUB
- KILL X,Y,Z,RD,DIE,DR,DA,D0,DQ,DI,DIC,%T,%Y,D,DIZ,DISYS,%
- 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
- AUTH ;;Check user for authorization to certify or issue
- +1 ;; input: NB
- +2 ;;output: RMPFOUT
- +3 SET X=$PIECE(RMPFSYS,U,NB)
- if 'X
- GOTO AUTHE
- +4 IF X=1
- IF $DATA(^RMPF(791813,RMPFSTAN,101,DUZ,0))
- GOTO AUTHE
- +5 IF $DATA(^XUSEC("RMPF SUPERVISOR",DUZ))
- GOTO AUTHE
- +6 WRITE $CHAR(7),!!,"*** YOU HAVE NOT BEEN AUTHORIZED TO ",$SELECT(NB=11:"CERTIFY ORDERS",1:"ISSUE CUSTOM AIDS")," ***"
- SET RMPFOUT=""
- AUTHE KILL X
- QUIT
- IU ;;Check to see if user is an audiologist
- +1 if '$PIECE(RMPFSYS,U,12)
- QUIT
- +2 IF $PIECE(RMPFSYS,U,12)=1
- IF $DATA(^RMPF(791813,RMPFSTAN,101,+Y,0))
- GOTO IUE
- +3 IF $PIECE(RMPFSYS,U,12)=2
- IF $DATA(^XUSEC("RMPF SUPERVISOR",+Y))
- GOTO IUE
- +4 WRITE $CHAR(7),!!,"*** ISSUING USER MUST BE AN AUDIOLOGIST - SEE YOUR ADPAC ***"
- KILL X,Y
- IUE QUIT
- STOCK ;;Check for issue delay in stock hearing aids
- +1 ;; input: RMPFX,RMPFY
- +2 ;;output: None
- +3 NEW DQ,DP,DC,DI,DL
- +4 SET S0=^RMPF(791810,RMPFX,101,RMPFY,0)
- DO SUB
- +5 SET X=$PIECE(^RMPF(791810,RMPFX,0),U,8)
- SET DA=RMPFY
- SET DA(1)=RMPFX
- +6 SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DR="90.12////"_X
- DO ^DIE
- +7 KILL DIE,DA,DR,DI,D0,D,DIC,DQ,X,S0
- QUIT
