- RMPFET85 ;DDC/KAW-CONTINUATION OF RMPFET84 [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- CERT ;;Set Custom Hearing Aid Order Certification
- ;; input: RMPFX,RMPFY,RMPFHAT,MD,BX
- ;;output: None
- S S0=$G(^RMPF(791810,RMPFX,101,RMPFY,0)),RMPFSTO=$P(S0,U,18)
- I RMPFSTO,$D(^RMPF(791810.2,RMPFSTO,0)) S RMPFSTO=$P(^(0),U,2)
- S IT=$P(S0,U,1) I IT,$D(^RMPF(791811,IT,0)) S IT=$P(^(0),U,1)
- C1 G C12:BX=1
- W !!,"Certify line item ",MD," (",IT,")","? YES// " D READ
- G CERTE:$D(RMPFOUT)
- C11 I $D(RMPFQUT) W !!,"Enter a <Y> or <RETURN> to certify the line item",!?5,"an <N> to exit." G C1
- S:Y="" Y="Y" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G C11
- G CERTE:"Nn"[Y
- C12 I RMPFSTO="E"!(RMPFSTO="D") D CLEAR^RMPFET61 G CERTE:'$D(RMPFSTO)
- S X="NOW",%DT="T" D ^%DT S TD=Y
- S AP=$P(S0,U,20) I 'AP S LA="R" G C2
- S LA=$P(S0,U,19) I LA="" S LA="R" G C2
- S LA=$S(LA="O":"R",LA'["R":LA_"R",AP&(LA["R"):LA,1:"R")
- C2 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
- S DR=".05" D ^DIE I $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,5)="" W !!,"*** SERIAL NUMBER REQUIRED FOR A CERTIFICATION ***" H 1 G CERTE
- S DR=".17////"_TD_";.19////"_LA_";.2////1"
- I $P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,8) S DR=DR_";90.1////"_DUZ_";90.11////"_TD
- E S DR=DR_";90.08////"_DUZ_";90.09////"_TD
- D ^DIE
- I DR'[90.1 G CERTE:'$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,8)
- E G CERTE:'$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10)
- I RMPFHAT="I" S DR=".18///ISSUE DATE PENDING" D ^DIE
- W !!,"*** Order " W:$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10) "Re-" W "Certified ***" H 1
- W ! S DIE="^RMPF(791810,",DA=RMPFX,DR=10.01 D ^DIE
- CERTE K S0,%DT,D0,DA,DI,DQ,DIC,IT,X,Y,DIE,DR,TD,AP,LA,RMPFBT,RMPFSTO 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[HRMPFET85 1862 printed Apr 23, 2025@18:51:02 Page 2
- RMPFET85 ;DDC/KAW-CONTINUATION OF RMPFET84 [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- CERT ;;Set Custom Hearing Aid Order Certification
- +1 ;; input: RMPFX,RMPFY,RMPFHAT,MD,BX
- +2 ;;output: None
- +3 SET S0=$GET(^RMPF(791810,RMPFX,101,RMPFY,0))
- SET RMPFSTO=$PIECE(S0,U,18)
- +4 IF RMPFSTO
- IF $DATA(^RMPF(791810.2,RMPFSTO,0))
- SET RMPFSTO=$PIECE(^(0),U,2)
- +5 SET IT=$PIECE(S0,U,1)
- IF IT
- IF $DATA(^RMPF(791811,IT,0))
- SET IT=$PIECE(^(0),U,1)
- C1 if BX=1
- GOTO C12
- +1 WRITE !!,"Certify line item ",MD," (",IT,")","? YES// "
- DO READ
- +2 if $DATA(RMPFOUT)
- GOTO CERTE
- C11 IF $DATA(RMPFQUT)
- WRITE !!,"Enter a <Y> or <RETURN> to certify the line item",!?5,"an <N> to exit."
- GOTO C1
- +1 if Y=""
- SET Y="Y"
- SET Y=$EXTRACT(Y,1)
- IF "YyNn"'[Y
- SET RMPFQUT=""
- GOTO C11
- +2 if "Nn"[Y
- GOTO CERTE
- C12 IF RMPFSTO="E"!(RMPFSTO="D")
- DO CLEAR^RMPFET61
- if '$DATA(RMPFSTO)
- GOTO CERTE
- +1 SET X="NOW"
- SET %DT="T"
- DO ^%DT
- SET TD=Y
- +2 SET AP=$PIECE(S0,U,20)
- IF 'AP
- SET LA="R"
- GOTO C2
- +3 SET LA=$PIECE(S0,U,19)
- IF LA=""
- SET LA="R"
- GOTO C2
- +4 SET LA=$SELECT(LA="O":"R",LA'["R":LA_"R",AP&(LA["R"):LA,1:"R")
- C2 SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA(1)=RMPFX
- SET DA=RMPFY
- +1 SET DR=".05"
- DO ^DIE
- IF $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,5)=""
- WRITE !!,"*** SERIAL NUMBER REQUIRED FOR A CERTIFICATION ***"
- HANG 1
- GOTO CERTE
- +2 SET DR=".17////"_TD_";.19////"_LA_";.2////1"
- +3 IF $PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,8)
- SET DR=DR_";90.1////"_DUZ_";90.11////"_TD
- +4 IF '$TEST
- SET DR=DR_";90.08////"_DUZ_";90.09////"_TD
- +5 DO ^DIE
- +6 IF DR'[90.1
- if '$PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,8)
- GOTO CERTE
- +7 IF '$TEST
- if '$PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10)
- GOTO CERTE
- +8 IF RMPFHAT="I"
- SET DR=".18///ISSUE DATE PENDING"
- DO ^DIE
- +9 WRITE !!,"*** Order "
- if $PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10)
- WRITE "Re-"
- WRITE "Certified ***"
- HANG 1
- +10 WRITE !
- SET DIE="^RMPF(791810,"
- SET DA=RMPFX
- SET DR=10.01
- DO ^DIE
- CERTE KILL S0,%DT,D0,DA,DI,DQ,DIC,IT,X,Y,DIE,DR,TD,AP,LA,RMPFBT,RMPFSTO
- 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
