- PRCH7PUC ;Hines OIFO/RVD - GUI PURCHASE CARD PROS ORDER INTERFACE ;8/13/03 09:50
- ;;5.1;IFCAP;**68,123,141**;Oct 20, 2000;Build 11
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;This routine is for Obligating and canceling a PO using a GUI interface.
- ;Line label UP1 is for MUMPS entry point.
- ;
- ; PRCSITE - station number
- ; PRCVEN - vendor
- ; RESULTS - return variable
- ; PRCA - IEN of Prosthetics Order file 664
- ; PRCB - IEN of file 442
- ; PRCC - Total Cost
- ; PRCRMPR - Variable to quit in IFCAP E-Sig routine PRCUESIG
- UP1(X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) ;ENTRY FOR GUI PURCHASING
- ;
- N PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
- N PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
- S PRC("PER")=+DUZ
- K X S X=$S('$D(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
- I $P(X,"^",2)="" S %X=$P(^VA(200,+PRC("PER"),0),"^"),%X=$P(%X,",",2)_" "_$P(%X,",")_$P(%X,",",3),$P(^VA(200,+PRC("PER"),20),"^",2)=%X,X=%X K %X
- S $P(PRC("PER"),"^",2,4)=$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_$S($D(^VA(200,+PRC("PER"),.13)):$P(^(.13),"^",2),1:"")
- S PRCHVEN=PRCVEN
- 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"_";7////"_RMPRDLVD 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
- I '$D(Y) D PROS^PRCHNPO
- I $G(X)="#",$G(PRCRMPR)=1 D CANIC(PRCRI(442)) Q
- 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
- ;
- ;PRCPONO - IEN of file #442
- ;PRCA - IEN of file #664
- ;RESULTS - a return value
- ;
- ;cancel a PO. Call by Prosthetics GUI.
- C1(PRCA) G C2
- CAN(RESULTS,PRCPONO) ;broker entry point.
- C2 ;
- N PRCPROST,PRCHPC,A,B,X,Y
- S PRCPROST=99,PRCHPC=1
- L +^PRC(442,PRCA):1
- I '$T S RESULTS="Unable to Access P.O. in IFCAP." Q
- D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCA,".5///^S X=45")
- S DA=PRCA D C2237^PRCH442A K DA,%A,%B,%
- S RESULTS(0)="P.O. has been cancelled."
- Q
- ;END
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH7PUC 2812 printed Feb 18, 2025@23:31:52 Page 2
- PRCH7PUC ;Hines OIFO/RVD - GUI PURCHASE CARD PROS ORDER INTERFACE ;8/13/03 09:50
- +1 ;;5.1;IFCAP;**68,123,141**;Oct 20, 2000;Build 11
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;This routine is for Obligating and canceling a PO using a GUI interface.
- +5 ;Line label UP1 is for MUMPS entry point.
- +6 ;
- +7 ; PRCSITE - station number
- +8 ; PRCVEN - vendor
- +9 ; RESULTS - return variable
- +10 ; PRCA - IEN of Prosthetics Order file 664
- +11 ; PRCB - IEN of file 442
- +12 ; PRCC - Total Cost
- +13 ; PRCRMPR - Variable to quit in IFCAP E-Sig routine PRCUESIG
- UP1(X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) ;ENTRY FOR GUI PURCHASING
- +1 ;
- +2 NEW PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
- +3 NEW PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
- +4 SET PRC("PER")=+DUZ
- +5 KILL X
- SET X=$SELECT('$DATA(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
- +6 IF $PIECE(X,"^",2)=""
- SET %X=$PIECE(^VA(200,+PRC("PER"),0),"^")
- SET %X=$PIECE(%X,",",2)_" "_$PIECE(%X,",")_$PIECE(%X,",",3)
- SET $PIECE(^VA(200,+PRC("PER"),20),"^",2)=%X
- SET X=%X
- KILL %X
- +7 SET $PIECE(PRC("PER"),"^",2,4)=$PIECE(X,"^",2)_"^"_$PIECE(X,"^",3)_"^"_$SELECT($DATA(^VA(200,+PRC("PER"),.13)):$PIECE(^(.13),"^",2),1:"")
- +8 SET PRCHVEN=PRCVEN
- +9 SET PRCPROST=3
- SET PRCHPC=1
- +10 SET PRCRI(442)=PRCB
- +11 SET PRCHPO=PRCRI(442)
- SET PRCHTOT=PRCC
- +12 SET A=^PRC(440.5,$PIECE(^PRC(442,PRCRI(442),23),"^",8),0)
- SET PRCHBOC1=$PIECE(A,U,4)
- +13 SET DIE="^PRC(442,"
- SET DA=PRCHPO
- SET DR="60////"_PRCHTOT_";91////"_PRCHTOT_";65////RMPR"_";7////"_RMPRDLVD
- DO ^DIE
- KILL DR
- +14 SET PRCHN("SFC")=+$PIECE(^PRC(442,PRCRI(442),0),U,19)
- +15 if '$DATA(^PRC(442,PRCHPO,2,0))
- SET $PIECE(^PRC(442,PRCHPO,2,0),U,2)=$PIECE(^DD(442,40,0),U,2)
- +16 SET DA(1)=PRCHPO
- SET DIE="^PRC(442,"_DA(1)_",2,"
- SET DA=1
- +17 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;"
- +18 SET DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
- +19 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"
- +20 DO ^DIE
- +21 IF '$DATA(Y)
- DO PROS^PRCHNPO
- +22 IF $GET(X)="#"
- IF $GET(PRCRMPR)=1
- DO CANIC(PRCRI(442))
- QUIT
- +23 SET X=""
- IF PRCPROST=3
- DO CANIC(PRCRI(442))
- SET X="^"
- +24 QUIT
- +25 ;
- 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 ;PRCPONO - IEN of file #442
- +8 ;PRCA - IEN of file #664
- +9 ;RESULTS - a return value
- +10 ;
- +11 ;cancel a PO. Call by Prosthetics GUI.
- C1(PRCA) GOTO C2
- CAN(RESULTS,PRCPONO) ;broker entry point.
- C2 ;
- +1 NEW PRCPROST,PRCHPC,A,B,X,Y
- +2 SET PRCPROST=99
- SET PRCHPC=1
- +3 LOCK +^PRC(442,PRCA):1
- +4 IF '$TEST
- SET RESULTS="Unable to Access P.O. in IFCAP."
- QUIT
- +5 DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCA,".5///^S X=45")
- +6 SET DA=PRCA
- DO C2237^PRCH442A
- KILL DA,%A,%B,%
- +7 SET RESULTS(0)="P.O. has been cancelled."
- +8 QUIT
- +9 ;END