- PRCH7B ;WISC/PLT/CR-PURCHASE CARD PROSTHETICS ORDER INTERFACE ;05/18/1998 @ 10:33
- V ;;5.1;IFCAP;**18**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- QUIT ;invalid entry
- ;
- ;.prca passing ^1= station #, ^2=ri of 440 (vendor)
- ;.prca return variable ^1=ri of 442, ^2=p.o. order # without station #
- ; ^3=card #
- ; or "^" for quit
- ADD(PRCA) ;add new order
- N PRCHPC,PRCPROST,PRCRI
- N DA,A,B,X,Y
- D DUZ^PRCFSITE
- S PRCRI(420)=+PRCA,PRC("SITE")=$P(PRCA,"^"),PRCRI(440)=$P(PRCA,"^",2)
- S X="" S:$D(PRC("SITE")) PRC("PARAM")=^PRC(411,PRC("SITE"),0)
- S (PRCPROST,PRCHPC)=1
- D ENPO^PRCHUTL G:'$D(PRCHPO) ADDEX D LCK1^PRCHE G:'$G(DA) ADDEX D ^PRCHNPO L -^PRC(442,DA)
- ADDEX S PRCA="" I PRCPROST=1.9 S PRCA=+DA,A=$P(^PRC(442,PRCA,0),"^"),$P(PRCA,"^",2)=$P(A,"-",2),$P(PRCA,"^",3)=$P($G(^(23)),"^",16)
- I PRCA="" D:$G(DA) CANIC(+DA) S PRCA="^"
- D
- . N PRCA D Q^PRCHNPO4
- . QUIT
- QUIT
- ;
- EDITIC(PRCA,PRCB) ;edit order, prca=ri of prostheic order, prcb=ri of file 442
- N PRCPROST,PRCHPC,PRCRI,DA,A,B,X,Y
- N FLG1 S FLG1=1
- S PRCPROST=2,PRCHPC=1
- D DUZ^PRCFSITE S PRC("SITE")=$P(^PRC(442,PRCB,0),"-")
- S:$D(PRC("SITE")) PRC("PARAM")=^PRC(411,PRC("SITE"),0)
- S PRCRI(442)=+PRCB,DA=+PRCB D LCK1^PRCHE S PRCHPO=PRCRI(442) D ^PRCHNPO L -^PRC(442,PRCRI(442))
- QUIT
- ;
- ;.X = "^" if abort
- OBL(X,PRCA,PRCB,PRCC) ;obligate order, prca=ri of prosthetic order, prcb=ri of file 442, prcc=total cost
- N PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
- N PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
- D DUZ^PRCFSITE
- S PRCPROST=3,PRCHPC=1
- S PRCRI(442)=PRCB
- S PRCHPO=PRCRI(442),PRCHTOT=PRCC
- S A=^PRC(440.5,$P(^PRC(442,PRCRI(442),23),"^",8),0),PRCHBOC1=$P(A,U,4)
- S DIE="^PRC(442,",DA=PRCHPO,DR="60////"_PRCHTOT_";91////"_PRCHTOT_";65////RMPR" D ^DIE K DR
- S PRCHN("SFC")=+$P(^PRC(442,PRCRI(442),0),U,19)
- S:'$D(^PRC(442,PRCHPO,2,0)) $P(^PRC(442,PRCHPO,2,0),U,2)=$P(^DD(442,40,0),U,2)
- S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",2,",DA=1
- S DR=".01///^S X=1;1///Prosthetic Order;2///^S X=1;3///^S X=""EA"";5////^S X=PRCHTOT;3.1///^S X=1;9.7///^S X=1;9///^S X="""";8///^S X=9999;K PRCHBOCC;"
- S DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
- S DR(1,442.01,2)="S PRCHBOCC=$P($G(^PRCD(420.2,PRCHBOCC,0)),U);3.5////^S X=PRCHBOCC;S Y=""@89"";@87;3.5////^S X=PRCHBOC1;@89;K PRCHBOCC"
- D ^DIE
- ;S DIE="^PRC(442,",DA=PRCHPO,DR=20 D ^DIE
- I '$D(Y) D PROS^PRCHNPO
- S X="" I PRCPROST=3 D CANIC(PRCRI(442)) S X="^"
- QUIT
- ;
- CANIC(PRCA) ;cancel order, prca=ri of prosthetic order, prcb=ri file 442
- N PRCPROST,PRCHPC,A,B,X,Y
- S PRCPROST=99,PRCHPC=1
- D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCA,".5///^S X=45")
- S DA=PRCA D C2237^PRCH442A K DA,%A,%B,%
- QUIT
- ;
- ;.x return variable ="^" if abort
- ; prca = ri of prosthetic order, prcb = ri of file 442, prcc=zero amount
- ; flag RMPRPRCH is used to notify RMPR when order cancellation is not
- ; allowed.
- CAN(X,PRCA,PRCB,PRCC) ;cancel prosthetic order
- N PRC,PRCRI,PRCPROST,PRCHAUTH
- N Y
- N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,NOCAN
- N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
- N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,PRCHPO,REPO,PRCHNORE,%,%A,%B,D0,D1,J
- N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,PRCHN,PRCHO,SFUND
- D DUZ^PRCFSITE
- S PRCHNEW="",PRCHNORE=1,CAN=1,RMPRPRCH=0,PRCHSTOP=""
- S PRCHAUTH=1,PRCPROST=90
- S PRCRI(442)=+PRCB,PRCHPO=PRCRI(442)
- S A=$P(^PRC(442,PRCRI(442),0),"^"),PRC("SITE")=$P(A,"-")
- I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G CANEX
- ; S B=5 D ICLOCK^PRC0B("^PRC(442,"_PRCHPO_",",.B)
- ; check if payment has been made, set flag RMPRPRCH and quit.
- I $D(^PRC(442,PRCHPO,7)) D Q:$G(RMPRPRCH)=1
- . S PRCHSTOP=$P($G(^PRC(442,PRCHPO,7)),U)
- . I $P($G(^PRCD(442.3,PRCHSTOP,0)),"(")="Paid " S RMPRPRCH=1
- . I $P($G(^PRCD(442.3,PRCHSTOP,0)),"(")="Partial Payment " S RMPRPRCH=1
- . I RMPRPRCH=1 S X="^" W !,$C(7),?5,"A PAYMENT HAS BEEN MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL!" H 3
- ; D AMENDNO^PRCHAMU D DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",") G:'$G(PRCHAM) CANEX
- ; check if entry is available.
- S PRCENTRY=PRCHPO
- L +^PRC(442,PRCHPO):0 E W !,"Someone else is editing this entry, try later." G CANEX
- ;
- ; check for any pending amendment for the order before creating another
- ; amendment.
- I $D(^PRC(443.6,PRCHPO,0)) D G:%'=1 CANEX
- . W @IOF,"*** You already have one pending amendment for this order. ***",!,$C(7)
- . W !," If you proceed, your previous amendment will be DELETED."
- . W !
- . S %=2,%B="",%A=" DO YOU REALLY WANT TO CONTINUE" D ^PRCFYN W !
- . Q:%'=1
- . W !," ...DELETING previous amendment..."
- . S Y=PRCHPO D DEL^PRCHAMU H 5 W "...DONE!" W !
- . W !," ...Preparing to cancel the order..." H 3 W !
- . S %=2,%B="",%A=" Continue with CANCELLATION" D ^PRCFYN W ! Q:%'=1
- ;
- D AMENDNO^PRCHAMU G:'$G(PRCHAM) CANEX
- S PRCHAMT=0,FL=0 D INFO^PRCHAMU G:$D(PRCHAV)!ER CANEX
- S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
- I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
- I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
- I $G(CAN)>0 D ENC^PRCHMA G:ER CANEX I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX D CAN1^PRCHMA
- K FIS,REPO,DEL
- CANEX S X="" I PRCPROST=90 S X="^"
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH7B 5431 printed Feb 18, 2025@23:31:47 Page 2
- PRCH7B ;WISC/PLT/CR-PURCHASE CARD PROSTHETICS ORDER INTERFACE ;05/18/1998 @ 10:33
- V ;;5.1;IFCAP;**18**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;invalid entry
- QUIT
- +3 ;
- +4 ;.prca passing ^1= station #, ^2=ri of 440 (vendor)
- +5 ;.prca return variable ^1=ri of 442, ^2=p.o. order # without station #
- +6 ; ^3=card #
- +7 ; or "^" for quit
- ADD(PRCA) ;add new order
- +1 NEW PRCHPC,PRCPROST,PRCRI
- +2 NEW DA,A,B,X,Y
- +3 DO DUZ^PRCFSITE
- +4 SET PRCRI(420)=+PRCA
- SET PRC("SITE")=$PIECE(PRCA,"^")
- SET PRCRI(440)=$PIECE(PRCA,"^",2)
- +5 SET X=""
- if $DATA(PRC("SITE"))
- SET PRC("PARAM")=^PRC(411,PRC("SITE"),0)
- +6 SET (PRCPROST,PRCHPC)=1
- +7 DO ENPO^PRCHUTL
- if '$DATA(PRCHPO)
- GOTO ADDEX
- DO LCK1^PRCHE
- if '$GET(DA)
- GOTO ADDEX
- DO ^PRCHNPO
- LOCK -^PRC(442,DA)
- ADDEX SET PRCA=""
- IF PRCPROST=1.9
- SET PRCA=+DA
- SET A=$PIECE(^PRC(442,PRCA,0),"^")
- SET $PIECE(PRCA,"^",2)=$PIECE(A,"-",2)
- SET $PIECE(PRCA,"^",3)=$PIECE($GET(^(23)),"^",16)
- +1 IF PRCA=""
- if $GET(DA)
- DO CANIC(+DA)
- SET PRCA="^"
- +2 Begin DoDot:1
- +3 NEW PRCA
- DO Q^PRCHNPO4
- +4 QUIT
- End DoDot:1
- +5 QUIT
- +6 ;
- EDITIC(PRCA,PRCB) ;edit order, prca=ri of prostheic order, prcb=ri of file 442
- +1 NEW PRCPROST,PRCHPC,PRCRI,DA,A,B,X,Y
- +2 NEW FLG1
- SET FLG1=1
- +3 SET PRCPROST=2
- SET PRCHPC=1
- +4 DO DUZ^PRCFSITE
- SET PRC("SITE")=$PIECE(^PRC(442,PRCB,0),"-")
- +5 if $DATA(PRC("SITE"))
- SET PRC("PARAM")=^PRC(411,PRC("SITE"),0)
- +6 SET PRCRI(442)=+PRCB
- SET DA=+PRCB
- DO LCK1^PRCHE
- SET PRCHPO=PRCRI(442)
- DO ^PRCHNPO
- LOCK -^PRC(442,PRCRI(442))
- +7 QUIT
- +8 ;
- +9 ;.X = "^" if abort
- OBL(X,PRCA,PRCB,PRCC) ;obligate order, prca=ri of prosthetic order, prcb=ri of file 442, prcc=total cost
- +1 NEW PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
- +2 NEW PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
- +3 DO DUZ^PRCFSITE
- +4 SET PRCPROST=3
- SET PRCHPC=1
- +5 SET PRCRI(442)=PRCB
- +6 SET PRCHPO=PRCRI(442)
- SET PRCHTOT=PRCC
- +7 SET A=^PRC(440.5,$PIECE(^PRC(442,PRCRI(442),23),"^",8),0)
- SET PRCHBOC1=$PIECE(A,U,4)
- +8 SET DIE="^PRC(442,"
- SET DA=PRCHPO
- SET DR="60////"_PRCHTOT_";91////"_PRCHTOT_";65////RMPR"
- DO ^DIE
- KILL DR
- +9 SET PRCHN("SFC")=+$PIECE(^PRC(442,PRCRI(442),0),U,19)
- +10 if '$DATA(^PRC(442,PRCHPO,2,0))
- SET $PIECE(^PRC(442,PRCHPO,2,0),U,2)=$PIECE(^DD(442,40,0),U,2)
- +11 SET DA(1)=PRCHPO
- SET DIE="^PRC(442,"_DA(1)_",2,"
- SET DA=1
- +12 SET DR=".01///^S X=1;1///Prosthetic Order;2///^S X=1;3///^S X=""EA"";5////^S X=PRCHTOT;3.1///^S X=1;9.7///^S X=1;9///^S X="""";8///^S X=9999;K PRCHBOCC;"
- +13 SET DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
- +14 SET DR(1,442.01,2)="S PRCHBOCC=$P($G(^PRCD(420.2,PRCHBOCC,0)),U);3.5////^S X=PRCHBOCC;S Y=""@89"";@87;3.5////^S X=PRCHBOC1;@89;K PRCHBOCC"
- +15 DO ^DIE
- +16 ;S DIE="^PRC(442,",DA=PRCHPO,DR=20 D ^DIE
- +17 IF '$DATA(Y)
- DO PROS^PRCHNPO
- +18 SET X=""
- IF PRCPROST=3
- DO CANIC(PRCRI(442))
- SET X="^"
- +19 QUIT
- +20 ;
- CANIC(PRCA) ;cancel order, prca=ri of prosthetic order, prcb=ri file 442
- +1 NEW PRCPROST,PRCHPC,A,B,X,Y
- +2 SET PRCPROST=99
- SET PRCHPC=1
- +3 DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCA,".5///^S X=45")
- +4 SET DA=PRCA
- DO C2237^PRCH442A
- KILL DA,%A,%B,%
- +5 QUIT
- +6 ;
- +7 ;.x return variable ="^" if abort
- +8 ; prca = ri of prosthetic order, prcb = ri of file 442, prcc=zero amount
- +9 ; flag RMPRPRCH is used to notify RMPR when order cancellation is not
- +10 ; allowed.
- CAN(X,PRCA,PRCB,PRCC) ;cancel prosthetic order
- +1 NEW PRC,PRCRI,PRCPROST,PRCHAUTH
- +2 NEW Y
- +3 NEW PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,NOCAN
- +4 NEW A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
- +5 NEW PRCHX,PRCHIMP,PRCHNRQ,PRCHP,PRCHPO,REPO,PRCHNORE,%,%A,%B,D0,D1,J
- +6 NEW PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,PRCHN,PRCHO,SFUND
- +7 DO DUZ^PRCFSITE
- +8 SET PRCHNEW=""
- SET PRCHNORE=1
- SET CAN=1
- SET RMPRPRCH=0
- SET PRCHSTOP=""
- +9 SET PRCHAUTH=1
- SET PRCPROST=90
- +10 SET PRCRI(442)=+PRCB
- SET PRCHPO=PRCRI(442)
- +11 SET A=$PIECE(^PRC(442,PRCRI(442),0),"^")
- SET PRC("SITE")=$PIECE(A,"-")
- +12 IF '$$VERIFY^PRCHES5(PRCHPO)
- WRITE !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",!
- GOTO CANEX
- +13 ; S B=5 D ICLOCK^PRC0B("^PRC(442,"_PRCHPO_",",.B)
- +14 ; check if payment has been made, set flag RMPRPRCH and quit.
- +15 IF $DATA(^PRC(442,PRCHPO,7))
- Begin DoDot:1
- +16 SET PRCHSTOP=$PIECE($GET(^PRC(442,PRCHPO,7)),U)
- +17 IF $PIECE($GET(^PRCD(442.3,PRCHSTOP,0)),"(")="Paid "
- SET RMPRPRCH=1
- +18 IF $PIECE($GET(^PRCD(442.3,PRCHSTOP,0)),"(")="Partial Payment "
- SET RMPRPRCH=1
- +19 IF RMPRPRCH=1
- SET X="^"
- WRITE !,$CHAR(7),?5,"A PAYMENT HAS BEEN MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL!"
- HANG 3
- End DoDot:1
- if $GET(RMPRPRCH)=1
- QUIT
- +20 ; D AMENDNO^PRCHAMU D DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",") G:'$G(PRCHAM) CANEX
- +21 ; check if entry is available.
- +22 SET PRCENTRY=PRCHPO
- +23 LOCK +^PRC(442,PRCHPO):0
- IF '$TEST
- WRITE !,"Someone else is editing this entry, try later."
- GOTO CANEX
- +24 ;
- +25 ; check for any pending amendment for the order before creating another
- +26 ; amendment.
- +27 IF $DATA(^PRC(443.6,PRCHPO,0))
- Begin DoDot:1
- +28 WRITE @IOF,"*** You already have one pending amendment for this order. ***",!,$CHAR(7)
- +29 WRITE !," If you proceed, your previous amendment will be DELETED."
- +30 WRITE !
- +31 SET %=2
- SET %B=""
- SET %A=" DO YOU REALLY WANT TO CONTINUE"
- DO ^PRCFYN
- WRITE !
- +32 if %'=1
- QUIT
- +33 WRITE !," ...DELETING previous amendment..."
- +34 SET Y=PRCHPO
- DO DEL^PRCHAMU
- HANG 5
- WRITE "...DONE!"
- WRITE !
- +35 WRITE !," ...Preparing to cancel the order..."
- HANG 3
- WRITE !
- +36 SET %=2
- SET %B=""
- SET %A=" Continue with CANCELLATION"
- DO ^PRCFYN
- WRITE !
- if %'=1
- QUIT
- End DoDot:1
- if %'=1
- GOTO CANEX
- +37 ;
- +38 DO AMENDNO^PRCHAMU
- if '$GET(PRCHAM)
- GOTO CANEX
- +39 SET PRCHAMT=0
- SET FL=0
- DO INFO^PRCHAMU
- if $DATA(PRCHAV)!ER
- GOTO CANEX
- +40 SET X=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U,16)
- DO EN2^PRCHAMXB
- +41 IF PRCHNEW=""
- SET DA(1)=PRCHPO
- SET DA=PRCHAM
- SET PRCHX=X
- SET X=0
- SET PRCHAMDA=34
- DO EN8^PRCHAMXB
- SET X=PRCHX
- +42 IF $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($PIECE(^(0),U,4)=15)
- SET CAN=1
- +43 IF $GET(CAN)>0
- DO ENC^PRCHMA
- if ER
- GOTO CANEX
- IF $GET(NOCAN)=0
- SET DA(1)=PRCHPO
- SET DA=PRCHAM
- SET PRCHAMDA=34
- SET PRCHX=X
- SET X=0
- DO EN8^PRCHAMXB
- SET X=PRCHX
- DO CAN1^PRCHMA
- +44 KILL FIS,REPO,DEL
- CANEX SET X=""
- IF PRCPROST=90
- SET X="^"
- +1 QUIT