PRCH7D ;WISC/PLT - PURCHASE CARD HOME OXYGEN ORDER (BILLING) INTERFACE ; 8/23/99 2:45pm
V ;;5.1;IFCAP;;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 PRC,PRCHPC,PRCPROST,PRCRI
N OUT,PRCHBOC1,PRCHCC,PRCHCD,PRCHCDF,PRCHCDFT,PRCHCDNO,PRCHDLOC,PRCHHLDR,PRCHIEN,PRCHII,PRCHNN,PRCHP0,PRCHVEN,PRCHXXX,PRCY,STR1
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 PRCRI(442)=+DA,PRCA=+DA,A=$P(^PRC(442,PRCA,0),"^"),$P(PRCA,"^",2)=$P(A,"-",2),$P(PRCA,"^",3)=$P($G(^(23)),"^",16)
I PRCA D
. S A="442;^PRC(442,;"_PRCRI(442)_";20~442.04;^PRC(442,"_PRCRI(442)_",4,"
. S X="|NOWRAP|"
. D ADD^PRC0B1(.X,.Y,A)
. QUIT
I PRCA="" D:$G(DA) CANIC(+DA) S PRCA="^"
D
. N PRCA D Q^PRCHNPO4
. QUIT
QUIT
;
;prca=monthly total amount of home oxygen bill (not partial amount)
;prcb=ri of file 442
;prcc=array variable name (may be local or global and data stored in first dimenension)
EDITIC(PRCA,PRCB,PRCC) ;edit order with patient and patient amount
N PRC,PRCPROST,PRCHOM,PRCHPC,PRCRI,DA,A,B
N PRCHBOC1,PRCHCC,PRCHCD,PRCHCDF,PRCHCDFT,PRCHCDNO,PRCHDLOC,PRCHFCP,PRCHHLDR,PRCHIEN,PRCHII,PRCHLOG,PRCHN,PRCHNN,PRCHP0,PRCHPO,PRCHPONO,PRCHSTN,PRCHTOT,PRCHVEN,PRCHXXX,PRCY,STR1
N FLG1 S FLG1=1
S (PRCPROST,PRCHOM)=2,PRCHPC=1
D PRC(PRCB)
S PRCRI(442)=+PRCB D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"60////"_PRCA_";91////"_PRCA)
;add patient and patient amount in comments field #20
I X>0 S PRCRI="" F S PRCRI=$O(@(PRCC_"(PRCRI)")) QUIT:'PRCRI D
. S A="442;^PRC(442,;"_PRCRI(442)_";20~442.04;^PRC(442,"_PRCRI(442)_",4,"
. S X=@(PRCC_"(PRCRI)")
. D ADD^PRC0B1(.X,.Y,A)
. QUIT
QUIT
;
;.X = "^" if abort
OBL(X,PRCA,PRCB,PRCC) ;obligate order, prca="" not in use, prcb=ri of file 442, prcc=monthly total amount of home oxygen bill
N PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
N N,PRC,NET,PO,PODIEPRC,PRCHCD,PRCHCI,PRCHCPO,PRCHOBL,PRCHPOMT,PRCHSP,PRCSINV,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4,SHPGBOC,STA,X1
N PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
D DUZ^PRCFSITE,PRC(PRCB)
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///Home Oxygen Monthly Billing;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=ien of 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 = "" not in use, prcb = ri of file 442, prcc=zero amount
CAN(X,PRCA,PRCB,PRCC) ;cancel home oxygen billing 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
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)
D AMENDNO^PRCHAMU D DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",") 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
;
PRC(X) ;x = ien of file 442, return PRC local array for site, bbfy, fy, qtr
S PRC("SITE")=$P($G(^PRC(442,X,0)),"-"),PRC("BBFY")=$P($G(^(23)),"^",2)/10000+1700,X=$$DATE^PRC0C($P($G(^(1)),"^",15),"I")
S PRC("FY")=$E(X,3,4),PRC("QTR")=$P(X,"^",2)
S PRC("PARAM")=^PRC(411,PRC("SITE"),0) D DUZ^PRCFSITE
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH7D 5410 printed Dec 13, 2024@02:05:26 Page 2
PRCH7D ;WISC/PLT - PURCHASE CARD HOME OXYGEN ORDER (BILLING) INTERFACE ; 8/23/99 2:45pm
V ;;5.1;IFCAP;;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 PRC,PRCHPC,PRCPROST,PRCRI
+2 NEW OUT,PRCHBOC1,PRCHCC,PRCHCD,PRCHCDF,PRCHCDFT,PRCHCDNO,PRCHDLOC,PRCHHLDR,PRCHIEN,PRCHII,PRCHNN,PRCHP0,PRCHVEN,PRCHXXX,PRCY,STR1
+3 NEW DA,A,B,X,Y
+4 DO DUZ^PRCFSITE
+5 SET PRCRI(420)=+PRCA
SET PRC("SITE")=$PIECE(PRCA,"^")
SET PRCRI(440)=$PIECE(PRCA,"^",2)
+6 SET X=""
if $DATA(PRC("SITE"))
SET PRC("PARAM")=^PRC(411,PRC("SITE"),0)
+7 SET (PRCPROST,PRCHPC)=1
+8 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 PRCRI(442)=+DA
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
Begin DoDot:1
+2 SET A="442;^PRC(442,;"_PRCRI(442)_";20~442.04;^PRC(442,"_PRCRI(442)_",4,"
+3 SET X="|NOWRAP|"
+4 DO ADD^PRC0B1(.X,.Y,A)
+5 QUIT
End DoDot:1
+6 IF PRCA=""
if $GET(DA)
DO CANIC(+DA)
SET PRCA="^"
+7 Begin DoDot:1
+8 NEW PRCA
DO Q^PRCHNPO4
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
+12 ;prca=monthly total amount of home oxygen bill (not partial amount)
+13 ;prcb=ri of file 442
+14 ;prcc=array variable name (may be local or global and data stored in first dimenension)
EDITIC(PRCA,PRCB,PRCC) ;edit order with patient and patient amount
+1 NEW PRC,PRCPROST,PRCHOM,PRCHPC,PRCRI,DA,A,B
+2 NEW PRCHBOC1,PRCHCC,PRCHCD,PRCHCDF,PRCHCDFT,PRCHCDNO,PRCHDLOC,PRCHFCP,PRCHHLDR,PRCHIEN,PRCHII,PRCHLOG,PRCHN,PRCHNN,PRCHP0,PRCHPO,PRCHPONO,PRCHSTN,PRCHTOT,PRCHVEN,PRCHXXX,PRCY,STR1
+3 NEW FLG1
SET FLG1=1
+4 SET (PRCPROST,PRCHOM)=2
SET PRCHPC=1
+5 DO PRC(PRCB)
+6 SET PRCRI(442)=+PRCB
DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"60////"_PRCA_";91////"_PRCA)
+7 ;add patient and patient amount in comments field #20
+8 IF X>0
SET PRCRI=""
FOR
SET PRCRI=$ORDER(@(PRCC_"(PRCRI)"))
if 'PRCRI
QUIT
Begin DoDot:1
+9 SET A="442;^PRC(442,;"_PRCRI(442)_";20~442.04;^PRC(442,"_PRCRI(442)_",4,"
+10 SET X=@(PRCC_"(PRCRI)")
+11 DO ADD^PRC0B1(.X,.Y,A)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
+15 ;.X = "^" if abort
OBL(X,PRCA,PRCB,PRCC) ;obligate order, prca="" not in use, prcb=ri of file 442, prcc=monthly total amount of home oxygen bill
+1 NEW PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
+2 NEW N,PRC,NET,PO,PODIEPRC,PRCHCD,PRCHCI,PRCHCPO,PRCHOBL,PRCHPOMT,PRCHSP,PRCSINV,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4,SHPGBOC,STA,X1
+3 NEW PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
+4 DO DUZ^PRCFSITE
DO PRC(PRCB)
+5 SET PRCPROST=3
SET PRCHPC=1
+6 SET PRCRI(442)=PRCB
+7 SET PRCHPO=PRCRI(442)
SET PRCHTOT=PRCC
+8 SET A=^PRC(440.5,$PIECE(^PRC(442,PRCRI(442),23),"^",8),0)
SET PRCHBOC1=$PIECE(A,U,4)
+9 SET DIE="^PRC(442,"
SET DA=PRCHPO
SET DR="60////"_PRCHTOT_";91////"_PRCHTOT_";65////RMPR"
DO ^DIE
KILL DR
+10 SET PRCHN("SFC")=+$PIECE(^PRC(442,PRCRI(442),0),U,19)
+11 if '$DATA(^PRC(442,PRCHPO,2,0))
SET $PIECE(^PRC(442,PRCHPO,2,0),U,2)=$PIECE(^DD(442,40,0),U,2)
+12 SET DA(1)=PRCHPO
SET DIE="^PRC(442,"_DA(1)_",2,"
SET DA=1
+13 SET DR=".01///^S X=1;1///Home Oxygen Monthly Billing;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;"
+14 SET DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
+15 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"
+16 DO ^DIE
+17 ;S DIE="^PRC(442,",DA=PRCHPO,DR=20 D ^DIE
+18 IF '$DATA(Y)
DO PROS^PRCHNPO
+19 SET X=""
IF PRCPROST=3
DO CANIC(PRCRI(442))
SET X="^"
+20 QUIT
+21 ;
CANIC(PRCA) ;cancel order, prca=ien of 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 = "" not in use, prcb = ri of file 442, prcc=zero amount
CAN(X,PRCA,PRCB,PRCC) ;cancel home oxygen billing 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
+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 SET B=5
DO ICLOCK^PRC0B("^PRC(442,"_PRCHPO_",",.B)
+14 DO AMENDNO^PRCHAMU
DO DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",")
if '$GET(PRCHAM)
GOTO CANEX
+15 SET PRCHAMT=0
SET FL=0
DO INFO^PRCHAMU
if $DATA(PRCHAV)!ER
GOTO CANEX
+16 SET X=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U,16)
DO EN2^PRCHAMXB
+17 IF PRCHNEW=""
SET DA(1)=PRCHPO
SET DA=PRCHAM
SET PRCHX=X
SET X=0
SET PRCHAMDA=34
DO EN8^PRCHAMXB
SET X=PRCHX
+18 IF $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($PIECE(^(0),U,4)=15)
SET CAN=1
+19 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
+20 KILL FIS,REPO,DEL
CANEX SET X=""
IF PRCPROST=90
SET X="^"
+1 QUIT
+2 ;
PRC(X) ;x = ien of file 442, return PRC local array for site, bbfy, fy, qtr
+1 SET PRC("SITE")=$PIECE($GET(^PRC(442,X,0)),"-")
SET PRC("BBFY")=$PIECE($GET(^(23)),"^",2)/10000+1700
SET X=$$DATE^PRC0C($PIECE($GET(^(1)),"^",15),"I")
+2 SET PRC("FY")=$EXTRACT(X,3,4)
SET PRC("QTR")=$PIECE(X,"^",2)
+3 SET PRC("PARAM")=^PRC(411,PRC("SITE"),0)
DO DUZ^PRCFSITE
+4 QUIT
