- RMPR4UTL ;PHX/HNB - PURCHASE CARD MODULE ;3/1/1996
- ;;3.0;PROSTHETICS;**3,12,20,25,30,44,41**;Feb 09, 1996
- Q
- EDT ;Edit Purchase Card
- S HY=+Y I '$D(^RMPR(664,RMPRA,1)) S ^RMPR(664,RMPRA,1,0)="^664.02PA^0^0" G FILE
- I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK
- FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1
- ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," ;S DR=$S($D(NEW):"",1:".01;") K NEW
- S DR="17;16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
- S DR=DR_"14;3;2;4R;11////C;7"
- D ^DIE Q:$D(DTOUT) K NUM,DA,NEW,Y,DR Q
- NFRM S DR=DR_"17;8TYPE OF TRANSACTION;9PATIENT CATEGORY;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;3QTY;2;4UNIT OF ISSUE;11////C;"
- S DR=DR_"7REMARKS;S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"";"
- D ^DIE K NUM,DA,NEW,Y,DR
- Q
- ;
- SS ;add IFCAP Site Parameter
- D DIV4^RMPRSIT Q:$D(X)
- W !!,?5,"Enter the IFCAP Site used with the Purchase Card Module"
- W !,?5,"The following site you select will be used on all your"
- W !,?5,"Purchase Card Transactions in IFCAP only.",!
- D ^PRCFSITE
- S:$G(PRC("SITE"))'="" $P(^RMPR(669.9,RMPRSITE,4),U,1)=PRC("SITE")
- D KILL^XUSCLEAN
- Q
- CHK ;Add Duplicate Item
- K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I X["Y"!(X["y") G FILE
- S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1
- LKP ;DISPLAY DUPLICATE AND SINGLE ITEMS
- I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP
- .F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$P(RD(RDA),U,3)
- .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y
- G ENT
- ;
- CHKCPT(RDATA) ;check for cpt modifier, change of Type of Transaction.
- ;
- N RMHCPC,RMCPT,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- S RMTYPE=$P(RDATA,U,1),RMPRA=$P(RDATA,U,2),R4DA=$P(RDATA,U,3)
- Q:'$D(^RMPR(664,RMPRA,1,R4DA))
- S RMHCPC=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16) Q:'$G(RMHCPC)
- S RMCPT=$P($G(^RMPR(664,RMPRA,1,R4DA,4)),U,2)
- I ((RMTYPE="R")!(RMTYPE="X")),(RMCPT'["RP"),($G(^RMPR(661.1,RMHCPC,4))["RP") D ADDRP
- I ((RMTYPE="I")!(RMTYPE="S")),(RMCPT["RP") D DELRP
- K RMHCPC,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- Q
- ;return to (PC) close out option
- DELRP ;logic for deleting 'RP' modifier with transaction change.
- F RMCI=1:1:8 S RMC=$P(RMCPT,",",RMCI) I RMC="RP" S $P(RMCPT,",",RMCI)="" D
- .S RMF=$F(RMCPT,",,"),RMFPIECE=$E(RMCPT,1,RMF-2)
- .S RMLPIECE=$E(RMCPT,RMF,32),RMCPT=RMFPIECE_RMLPIECE
- .S RMCLEN=$L(RMCPT)
- .I $E(RMCPT,1)="," S RMCPT=$E(RMCPT,2,RMCLEN)
- .I $E(RMCPT,RMCLEN)="," S RMCPT=$E(RMCPT,1,RMCLEN-1)
- .S $P(^RMPR(664,RMPRA,1,R4DA,4),U,2)=RMCPT
- ;
- Q
- ;
- ADDRP ;logic for adding 'RP' modifier with transaction change.
- S RMCPT=RMCPT_",RP" S $P(^RMPR(664,RMPRA,1,R4DA,4),U,2)=RMCPT
- Q
- ;end
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4UTL 3144 printed Jan 18, 2025@03:34:06 Page 2
- RMPR4UTL ;PHX/HNB - PURCHASE CARD MODULE ;3/1/1996
- +1 ;;3.0;PROSTHETICS;**3,12,20,25,30,44,41**;Feb 09, 1996
- +2 QUIT
- EDT ;Edit Purchase Card
- +1 SET HY=+Y
- IF '$DATA(^RMPR(664,RMPRA,1))
- SET ^RMPR(664,RMPRA,1,0)="^664.02PA^0^0"
- GOTO FILE
- +2 IF $DATA(^RMPR(664,RMPRA,1,"B",+Y))
- SET DA=$ORDER(^RMPR(664,RMPRA,1,"B",+Y,0))
- GOTO CHK
- FILE SET Y=HY
- SET NUM=$PIECE(^RMPR(664,RMPRA,1,0),U,4)+1
- SET $PIECE(^(0),U,4)=NUM
- SET $PIECE(^(0),U,3)=$PIECE(^(0),U,3)+1
- SET ^RMPR(664,RMPRA,1,NUM,0)=+Y
- SET DA=NUM
- SET ^RMPR(664,RMPRA,1,"B",+Y,NUM)=""
- SET NEW=1
- ENT ;S DR=$S($D(NEW):"",1:".01;") K NEW
- KILL DR,DQ
- SET DA(1)=RMPRA
- SET DIE="^RMPR(664,"_RMPRA_",1,"
- +1 SET DR="17;16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
- +2 SET DR=DR_"14;3;2;4R;11////C;7"
- +3 DO ^DIE
- if $DATA(DTOUT)
- QUIT
- KILL NUM,DA,NEW,Y,DR
- QUIT
- NFRM SET DR=DR_"17;8TYPE OF TRANSACTION;9PATIENT CATEGORY;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;3QTY;2;4UNIT OF ISSUE;11////C;"
- +1 SET DR=DR_"7REMARKS;S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"";"
- +2 DO ^DIE
- KILL NUM,DA,NEW,Y,DR
- +3 QUIT
- +4 ;
- SS ;add IFCAP Site Parameter
- +1 DO DIV4^RMPRSIT
- if $DATA(X)
- QUIT
- +2 WRITE !!,?5,"Enter the IFCAP Site used with the Purchase Card Module"
- +3 WRITE !,?5,"The following site you select will be used on all your"
- +4 WRITE !,?5,"Purchase Card Transactions in IFCAP only.",!
- +5 DO ^PRCFSITE
- +6 if $GET(PRC("SITE"))'=""
- SET $PIECE(^RMPR(669.9,RMPRSITE,4),U,1)=PRC("SITE")
- +7 DO KILL^XUSCLEAN
- +8 QUIT
- CHK ;Add Duplicate Item
- +1 KILL DIR,Y
- SET DIR(0)="S^Y:YES;N:NO"
- SET DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?"
- SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DIRUT)!($DATA(DTOUT))
- QUIT
- IF X["Y"!(X["y")
- GOTO FILE
- +2 SET RD=0
- FOR RDA=0:0
- SET RDA=$ORDER(^RMPR(664,RMPRA,1,"B",HY,RDA))
- if RDA'>0
- QUIT
- SET RD=RD+1
- LKP ;DISPLAY DUPLICATE AND SINGLE ITEMS
- +1 IF RD>1
- Begin DoDot:1
- +2 FOR RDA=0:0
- SET RDA=$ORDER(^RMPR(664,RMPRA,1,"B",HY,RDA))
- if RDA'>0
- QUIT
- SET RD(RDA)=^RMPR(664,RMPRA,1,RDA,0)
- WRITE !?5,RDA,?10,$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(RD(RDA),U),0),U),0),U,2)," $",$PIECE(RD(RDA),U,3)
- +3 KILL DIR,Y
- SET DIR(0)="N"
- DO ^DIR
- IF +Y
- SET DA=+Y
- End DoDot:1
- if $DATA(DIRUT)!$DATA(DTOUT)
- QUIT
- IF '$DATA(RD(+Y))
- WRITE $CHAR(7)
- GOTO LKP
- +4 GOTO ENT
- +5 ;
- CHKCPT(RDATA) ;check for cpt modifier, change of Type of Transaction.
- +1 ;
- +2 NEW RMHCPC,RMCPT,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- +3 SET RMTYPE=$PIECE(RDATA,U,1)
- SET RMPRA=$PIECE(RDATA,U,2)
- SET R4DA=$PIECE(RDATA,U,3)
- +4 if '$DATA(^RMPR(664,RMPRA,1,R4DA))
- QUIT
- +5 SET RMHCPC=$PIECE($GET(^RMPR(664,RMPRA,1,R4DA,0)),U,16)
- if '$GET(RMHCPC)
- QUIT
- +6 SET RMCPT=$PIECE($GET(^RMPR(664,RMPRA,1,R4DA,4)),U,2)
- +7 IF ((RMTYPE="R")!(RMTYPE="X"))
- IF (RMCPT'["RP")
- IF ($GET(^RMPR(661.1,RMHCPC,4))["RP")
- DO ADDRP
- +8 IF ((RMTYPE="I")!(RMTYPE="S"))
- IF (RMCPT["RP")
- DO DELRP
- +9 KILL RMHCPC,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- +10 QUIT
- +11 ;return to (PC) close out option
- DELRP ;logic for deleting 'RP' modifier with transaction change.
- +1 FOR RMCI=1:1:8
- SET RMC=$PIECE(RMCPT,",",RMCI)
- IF RMC="RP"
- SET $PIECE(RMCPT,",",RMCI)=""
- Begin DoDot:1
- +2 SET RMF=$FIND(RMCPT,",,")
- SET RMFPIECE=$EXTRACT(RMCPT,1,RMF-2)
- +3 SET RMLPIECE=$EXTRACT(RMCPT,RMF,32)
- SET RMCPT=RMFPIECE_RMLPIECE
- +4 SET RMCLEN=$LENGTH(RMCPT)
- +5 IF $EXTRACT(RMCPT,1)=","
- SET RMCPT=$EXTRACT(RMCPT,2,RMCLEN)
- +6 IF $EXTRACT(RMCPT,RMCLEN)=","
- SET RMCPT=$EXTRACT(RMCPT,1,RMCLEN-1)
- +7 SET $PIECE(^RMPR(664,RMPRA,1,R4DA,4),U,2)=RMCPT
- End DoDot:1
- +8 ;
- +9 QUIT
- +10 ;
- ADDRP ;logic for adding 'RP' modifier with transaction change.
- +1 SET RMCPT=RMCPT_",RP"
- SET $PIECE(^RMPR(664,RMPRA,1,R4DA,4),U,2)=RMCPT
- +2 QUIT
- +3 ;end