RMPOBILU ;EDS/MDB,RVD - HOME OXYGEN BILLING TRANSACTIONS ;8/7/98 10:58
;;3.0;PROSTHETICS;**29,43,44,77**;Feb 09, 1996
;RVD 3/18/03 patch #77 - don't allow future billing month creation
;
Q
VDRSCRN ; SCREEN
Q
I '$D(RMPOXITE) D Q
. W !,$C(7)_"RMPOXITE NOT DEFINED!"
. S DIC("S")="I 0"
S DIC("S")="I $D(^RMPR(669.9,RMPOXITE,""RMPOVDR"",Y,0))"
Q
XFRM1 ; INPUT XFORM FOR BILLING MONTH, FILE 665.72
S %DT(0)=-DT
S %DT="E" D ^%DT S X=Y I Y<0 K X Q
S (DINUM,X)=$E(X,1,5)_"00"
Q
2319 ; -- Display 2319
N RMPRNAM,RMPRDOB,RMPRSSN,RMPRDFN
S (DFN,RMPRDFN)=RMPODFN D DEM^VADPT
S RMPRNAM=VADM(1)
S RMPRDOB=+VADM(3)
S RMPRSSN=+VADM(2)
S $P(RMPR("L"),"-",80)=""
S RMPRBAC1=1
D ^RMPRPAT
K RMPRBAC1
Q
ACCEPT ; ACCEPT TRX
D SAME S DR="2///Y" D ^DIE
Q
UNACCEPT ; UNACCEPT TRX
D SAME S DR="2///N" D ^DIE
Q
SAME ;
K DIE,DA,DR
S DA=RMPODFN,DA(1)=RMPOVDR,DA(2)=RMPORVDT,DA(3)=RMPOXITE
S DIE="^RMPO(665.72,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",""V"","
Q
FCP(FCP) ;
;
; PASS:
; -- AS PARAMETER
; FCP = FREE-TEXT FUND CONTROL POINT NAME
; -- AS VARIABLES
; RMPOXITE = SITE #
; RMPODATE = BILLING MONTH
; RMPOVDR = VENDOR IEN (IF TYPE = 'PURCHASE CARD')
;
; RETURNS:
; TYPE ^ 442 IEN ^ REF # ^ AMOUNT ^ IEN
; TYPE = PAYMENT TYPE (1 = 1358, 'P' = PURCHASE CARD)
; 442 IEN = POINTER TO FILE 442, USED FOR POSTING
; REF # = C# FOR 1358, PCO# FOR PURCHASE CARD
; AMOUNT = TOTAL AMOUNT POSTED SO FAR (PURCHASE CARD ONLY)
; IEN = IEN OF 'FCP' RECORD IN FILE 665.72, USED FOR UPDATING TOTALS
;
N FOUND,DATA,RVDT,IEN,TMP,SITE,FN,TYPE
S QUIT=0,DATA="",FN=665.72
I '$D(RMPOXITE) W !,"SITE NOT DEFINED!" Q -1
I '$D(^RMPO(FN,RMPOXITE)) W !,"SITE NOT FOUND!" Q -1
S SITE=RMPOXITE
I '$D(RMPODATE) W !,"BILLING MONTH NOT DEFINED!" Q -1
S RVDT=RMPODATE
I '$D(^RMPO(FN,SITE,1,RVDT)) D Q -1
. W !,"BILLING MONTH NOT DEFINED!"
;
D FCP4 Q:FOUND DATA
D FCP1 Q:(Y="")!$$QUIT -1
S TYPE=Y
D FCP2:TYPE=1,FCP3:TYPE="P" Q:($G(Y)<0)!QUIT -1
Q DATA
Q
FCP4 ; LOOK FOR EXISTING PAYMENT TYPE
S FOUND=0,DATA=""
Q:'$D(^RMPO(FN,SITE,1,RVDT,2,"B",FCP))
K DIC S DA(1)=RVDT,DA(2)=SITE
S DIC("A")="Select Fund Control Point: "
S DIC="^RMPO(FN,"_DA(2)_",1,"_DA(1)_",2,",DIC(0)="AMQEZ"
S DIC("S")="S Z=^(0) I $P(Z,U)=FCP,$S($P(Z,U,2):1,($P(Z,U,2)=""P"")&"
S DIC("S")=DIC("S")_"($P(Z,U,5)=DUZ)&($P(Z,U,6)=RMPOVDR):1,1:0),"
S DIC("S")=DIC("S")_"$P(Z,U,8)="""""
S DIC("W")="W ?35,$P(^(0),U,4)"
S DIC("W")=DIC("W")_" I $P(^(0),U,2) W ?55,"
S DIC("W")=DIC("W")_"$J($$BAL^RMPOPST1($P(^(0),U,3)),10,2)"
D ^DIC
Q:(Y<0)!$$QUIT
K RMPOZ M RMPOZ=Y
K DIR S DIR(0)="Y"
S RMZ=^RMPO(FN,SITE,1,RVDT,2,+Y,0)
S RMZ=$P(RMZ,U,4)
S DIR("A")="Are you sure you want "_RMZ
S DIR("B")="NO" D ^DIR G:(Y=0) FCP4 Q:(Y'=1)!$$QUIT
K Y M Y=RMPOZ
I $P(Y(0),U,2) S DATA=$P(Y(0),U,2,4)_U_U_(+Y),FOUND=1 Q
S DATA=$P(Y(0),U,2)_U_$P(Y(0),U,3)_U
S DATA=DATA_$P(Y(0),U,4)_U_$P(Y(0),U,7)_U_(+Y),FOUND=1
Q
FCP2 ; 1358
S PRC("SITE")=RMPRS,PRC("CP")=FCP
S PRCS("A")="Select Obligation Number: "
D EN1A^PRCS58 Q:(Y<0)!$$QUIT
K RMPOZ M RMPOZ=Y
K DIR S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Are you sure" D ^DIR Q:(Y<1)!$$QUIT
K Y M Y=RMPOZ D FCPSET
K PRC,PRCS
Q
FCPSET ; SET ENTRY IN RMPO
S DATA=TYPE_U_$P(Y,U,1,2)_U_U ; SETUP RETURN VALUE
;Check if selected IFCAP order exist in file 665.72
S Y=$$FCPCHK(.DATA) I Y Q
K DIC,DIE,DA,DR,DD,DO
S DA(2)=SITE,DA(1)=RVDT
S DIC="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",2,"
S DIC("P")=$P(^DD(665.723,2,0),U,2)
S DIC(0)="L",X=FCP D FILE^DICN I Y<0 S DATA=-1 Q
S DIE=DIC,DA=+Y,DATA=DATA_DA
S DR="1////"_TYPE
S DR=DR_";2////"_$P(DATA,U,2)
S DR=DR_";3///"_$P(DATA,U,3)
S DR=DR_";4////"_DUZ
S:TYPE="P" DR=DR_";5////"_RMPOVDR
D ^DIE
S Z1=$P(DATA,U,2)
S Z2=$P(DATA,U,3)
S $P(^RMPO(665.72,DA(2),1,DA(1),2,DA,0),U,3,4)=Z1_U_Z2
Q
FCPCHK(DATA) ;CHECK IF FCP ALREADY EXIST IN FILE 665.72
N IEN,FDT,FPT,FOUND
S (IEN,FOUND)=0
F S IEN=$O(^RMPO(FN,SITE,1,RVDT,2,"B",FCP,IEN)) Q:IEN="" D Q:FOUND
. S FDT=^RMPO(FN,SITE,1,RVDT,2,IEN,0),FPT=$P(FDT,U,2)
. I $P(FDT,U,8)>0 Q ; closed flag
. I FPT=TYPE,$P(DATA,U,2)=$P(FDT,U,3),$P(DATA,U,3)=$P(FDT,U,4) D
. . I TYPE=1 S DATA=DATA_IEN,FOUND=1 Q
. . I $P(FDT,U,5)=DUZ,$P(FDT,U,6)=RMPOVDR D
. . . S $P(DATA,U,4)=$P(FDT,U,7),DATA=DATA_IEN,FOUND=1
Q FOUND
FCP3 ; PURCHASE CARD
N PRCA
I '$D(^PRC(440.5,"H",DUZ)) D S Y=-1 Q
. W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!"
S PRCA=RMPRS_U_RMPOVDR
D ADD^PRCH7D(.PRCA) S Y=PRCA Q:(Y<0)!(Y="^")!$$QUIT
K RMPOZ M RMPOZ=Y
K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure"
D ^DIR Q:(Y<1)!$$QUIT
K Y M Y=RMPOZ D FCPSET
Q
FCP1 ; PAYMENT TYPE
K DIR,DA
S DIR(0)="665.7232,1" D ^DIR
Q
GETFCP(DFCP) ; Return FCP from file 420 (External value only)
; Pass - DFCP = Default FCP [optional]
;
N DIC,DA
S:$D(DFCP) DIC("B")=DFCP
S DA(1)=RMPOXITE,DIC("A")="Select FUND CONTROL POINT: "
S DIC="^RMPR(669.9,"_DA(1)_",""RMPOFCP"",",DIC(0)="AEQMZ" D ^DIC
I Y<0!$$QUIT Q Y
Q Y_U_Y(0,0)
QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT
LJ(S,W,C) ; Left justify S in a field W wide padding with char F
;
S C=$G(C," ") ; Default pad char is space
S $P(S,C,W-$L(S)+$L(S,C))=""
Q $E(S,1,W)
Q
ENC(X,X1,X2) ;Encrypt
;Variable X = string to encrypt
; X1 = DUZ
; X2 = FCP IEN of file 665.72
D EN^XUSHSHP
Q X
DEC(X,X1,X2) ;Decrypt
;Variable X = encrypted string
; X1 = DUZ
; X2 = FCP IEN of file 665.72
D DE^XUSHSHP
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOBILU 5647 printed Dec 13, 2024@02:30:52 Page 2
RMPOBILU ;EDS/MDB,RVD - HOME OXYGEN BILLING TRANSACTIONS ;8/7/98 10:58
+1 ;;3.0;PROSTHETICS;**29,43,44,77**;Feb 09, 1996
+2 ;RVD 3/18/03 patch #77 - don't allow future billing month creation
+3 ;
+4 QUIT
VDRSCRN ; SCREEN
+1 QUIT
+2 IF '$DATA(RMPOXITE)
Begin DoDot:1
+3 WRITE !,$CHAR(7)_"RMPOXITE NOT DEFINED!"
+4 SET DIC("S")="I 0"
End DoDot:1
QUIT
+5 SET DIC("S")="I $D(^RMPR(669.9,RMPOXITE,""RMPOVDR"",Y,0))"
+6 QUIT
XFRM1 ; INPUT XFORM FOR BILLING MONTH, FILE 665.72
+1 SET %DT(0)=-DT
+2 SET %DT="E"
DO ^%DT
SET X=Y
IF Y<0
KILL X
QUIT
+3 SET (DINUM,X)=$EXTRACT(X,1,5)_"00"
+4 QUIT
2319 ; -- Display 2319
+1 NEW RMPRNAM,RMPRDOB,RMPRSSN,RMPRDFN
+2 SET (DFN,RMPRDFN)=RMPODFN
DO DEM^VADPT
+3 SET RMPRNAM=VADM(1)
+4 SET RMPRDOB=+VADM(3)
+5 SET RMPRSSN=+VADM(2)
+6 SET $PIECE(RMPR("L"),"-",80)=""
+7 SET RMPRBAC1=1
+8 DO ^RMPRPAT
+9 KILL RMPRBAC1
+10 QUIT
ACCEPT ; ACCEPT TRX
+1 DO SAME
SET DR="2///Y"
DO ^DIE
+2 QUIT
UNACCEPT ; UNACCEPT TRX
+1 DO SAME
SET DR="2///N"
DO ^DIE
+2 QUIT
SAME ;
+1 KILL DIE,DA,DR
+2 SET DA=RMPODFN
SET DA(1)=RMPOVDR
SET DA(2)=RMPORVDT
SET DA(3)=RMPOXITE
+3 SET DIE="^RMPO(665.72,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",""V"","
+4 QUIT
FCP(FCP) ;
+1 ;
+2 ; PASS:
+3 ; -- AS PARAMETER
+4 ; FCP = FREE-TEXT FUND CONTROL POINT NAME
+5 ; -- AS VARIABLES
+6 ; RMPOXITE = SITE #
+7 ; RMPODATE = BILLING MONTH
+8 ; RMPOVDR = VENDOR IEN (IF TYPE = 'PURCHASE CARD')
+9 ;
+10 ; RETURNS:
+11 ; TYPE ^ 442 IEN ^ REF # ^ AMOUNT ^ IEN
+12 ; TYPE = PAYMENT TYPE (1 = 1358, 'P' = PURCHASE CARD)
+13 ; 442 IEN = POINTER TO FILE 442, USED FOR POSTING
+14 ; REF # = C# FOR 1358, PCO# FOR PURCHASE CARD
+15 ; AMOUNT = TOTAL AMOUNT POSTED SO FAR (PURCHASE CARD ONLY)
+16 ; IEN = IEN OF 'FCP' RECORD IN FILE 665.72, USED FOR UPDATING TOTALS
+17 ;
+18 NEW FOUND,DATA,RVDT,IEN,TMP,SITE,FN,TYPE
+19 SET QUIT=0
SET DATA=""
SET FN=665.72
+20 IF '$DATA(RMPOXITE)
WRITE !,"SITE NOT DEFINED!"
QUIT -1
+21 IF '$DATA(^RMPO(FN,RMPOXITE))
WRITE !,"SITE NOT FOUND!"
QUIT -1
+22 SET SITE=RMPOXITE
+23 IF '$DATA(RMPODATE)
WRITE !,"BILLING MONTH NOT DEFINED!"
QUIT -1
+24 SET RVDT=RMPODATE
+25 IF '$DATA(^RMPO(FN,SITE,1,RVDT))
Begin DoDot:1
+26 WRITE !,"BILLING MONTH NOT DEFINED!"
End DoDot:1
QUIT -1
+27 ;
+28 DO FCP4
if FOUND
QUIT DATA
+29 DO FCP1
if (Y="")!$$QUIT
QUIT -1
+30 SET TYPE=Y
+31 if TYPE=1
DO FCP2
if TYPE="P"
DO FCP3
if ($GET(Y)<0)!QUIT
QUIT -1
+32 QUIT DATA
+33 QUIT
FCP4 ; LOOK FOR EXISTING PAYMENT TYPE
+1 SET FOUND=0
SET DATA=""
+2 if '$DATA(^RMPO(FN,SITE,1,RVDT,2,"B",FCP))
QUIT
+3 KILL DIC
SET DA(1)=RVDT
SET DA(2)=SITE
+4 SET DIC("A")="Select Fund Control Point: "
+5 SET DIC="^RMPO(FN,"_DA(2)_",1,"_DA(1)_",2,"
SET DIC(0)="AMQEZ"
+6 SET DIC("S")="S Z=^(0) I $P(Z,U)=FCP,$S($P(Z,U,2):1,($P(Z,U,2)=""P"")&"
+7 SET DIC("S")=DIC("S")_"($P(Z,U,5)=DUZ)&($P(Z,U,6)=RMPOVDR):1,1:0),"
+8 SET DIC("S")=DIC("S")_"$P(Z,U,8)="""""
+9 SET DIC("W")="W ?35,$P(^(0),U,4)"
+10 SET DIC("W")=DIC("W")_" I $P(^(0),U,2) W ?55,"
+11 SET DIC("W")=DIC("W")_"$J($$BAL^RMPOPST1($P(^(0),U,3)),10,2)"
+12 DO ^DIC
+13 if (Y<0)!$$QUIT
QUIT
+14 KILL RMPOZ
MERGE RMPOZ=Y
+15 KILL DIR
SET DIR(0)="Y"
+16 SET RMZ=^RMPO(FN,SITE,1,RVDT,2,+Y,0)
+17 SET RMZ=$PIECE(RMZ,U,4)
+18 SET DIR("A")="Are you sure you want "_RMZ
+19 SET DIR("B")="NO"
DO ^DIR
if (Y=0)
GOTO FCP4
if (Y'=1)!$$QUIT
QUIT
+20 KILL Y
MERGE Y=RMPOZ
+21 IF $PIECE(Y(0),U,2)
SET DATA=$PIECE(Y(0),U,2,4)_U_U_(+Y)
SET FOUND=1
QUIT
+22 SET DATA=$PIECE(Y(0),U,2)_U_$PIECE(Y(0),U,3)_U
+23 SET DATA=DATA_$PIECE(Y(0),U,4)_U_$PIECE(Y(0),U,7)_U_(+Y)
SET FOUND=1
+24 QUIT
FCP2 ; 1358
+1 SET PRC("SITE")=RMPRS
SET PRC("CP")=FCP
+2 SET PRCS("A")="Select Obligation Number: "
+3 DO EN1A^PRCS58
if (Y<0)!$$QUIT
QUIT
+4 KILL RMPOZ
MERGE RMPOZ=Y
+5 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
+6 SET DIR("A")="Are you sure"
DO ^DIR
if (Y<1)!$$QUIT
QUIT
+7 KILL Y
MERGE Y=RMPOZ
DO FCPSET
+8 KILL PRC,PRCS
+9 QUIT
FCPSET ; SET ENTRY IN RMPO
+1 ; SETUP RETURN VALUE
SET DATA=TYPE_U_$PIECE(Y,U,1,2)_U_U
+2 ;Check if selected IFCAP order exist in file 665.72
+3 SET Y=$$FCPCHK(.DATA)
IF Y
QUIT
+4 KILL DIC,DIE,DA,DR,DD,DO
+5 SET DA(2)=SITE
SET DA(1)=RVDT
+6 SET DIC="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",2,"
+7 SET DIC("P")=$PIECE(^DD(665.723,2,0),U,2)
+8 SET DIC(0)="L"
SET X=FCP
DO FILE^DICN
IF Y<0
SET DATA=-1
QUIT
+9 SET DIE=DIC
SET DA=+Y
SET DATA=DATA_DA
+10 SET DR="1////"_TYPE
+11 SET DR=DR_";2////"_$PIECE(DATA,U,2)
+12 SET DR=DR_";3///"_$PIECE(DATA,U,3)
+13 SET DR=DR_";4////"_DUZ
+14 if TYPE="P"
SET DR=DR_";5////"_RMPOVDR
+15 DO ^DIE
+16 SET Z1=$PIECE(DATA,U,2)
+17 SET Z2=$PIECE(DATA,U,3)
+18 SET $PIECE(^RMPO(665.72,DA(2),1,DA(1),2,DA,0),U,3,4)=Z1_U_Z2
+19 QUIT
FCPCHK(DATA) ;CHECK IF FCP ALREADY EXIST IN FILE 665.72
+1 NEW IEN,FDT,FPT,FOUND
+2 SET (IEN,FOUND)=0
+3 FOR
SET IEN=$ORDER(^RMPO(FN,SITE,1,RVDT,2,"B",FCP,IEN))
if IEN=""
QUIT
Begin DoDot:1
+4 SET FDT=^RMPO(FN,SITE,1,RVDT,2,IEN,0)
SET FPT=$PIECE(FDT,U,2)
+5 ; closed flag
IF $PIECE(FDT,U,8)>0
QUIT
+6 IF FPT=TYPE
IF $PIECE(DATA,U,2)=$PIECE(FDT,U,3)
IF $PIECE(DATA,U,3)=$PIECE(FDT,U,4)
Begin DoDot:2
+7 IF TYPE=1
SET DATA=DATA_IEN
SET FOUND=1
QUIT
+8 IF $PIECE(FDT,U,5)=DUZ
IF $PIECE(FDT,U,6)=RMPOVDR
Begin DoDot:3
+9 SET $PIECE(DATA,U,4)=$PIECE(FDT,U,7)
SET DATA=DATA_IEN
SET FOUND=1
End DoDot:3
End DoDot:2
End DoDot:1
if FOUND
QUIT
+10 QUIT FOUND
FCP3 ; PURCHASE CARD
+1 NEW PRCA
+2 IF '$DATA(^PRC(440.5,"H",DUZ))
Begin DoDot:1
+3 WRITE !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!"
End DoDot:1
SET Y=-1
QUIT
+4 SET PRCA=RMPRS_U_RMPOVDR
+5 DO ADD^PRCH7D(.PRCA)
SET Y=PRCA
if (Y<0)!(Y="^")!$$QUIT
QUIT
+6 KILL RMPOZ
MERGE RMPOZ=Y
+7 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are you sure"
+8 DO ^DIR
if (Y<1)!$$QUIT
QUIT
+9 KILL Y
MERGE Y=RMPOZ
DO FCPSET
+10 QUIT
FCP1 ; PAYMENT TYPE
+1 KILL DIR,DA
+2 SET DIR(0)="665.7232,1"
DO ^DIR
+3 QUIT
GETFCP(DFCP) ; Return FCP from file 420 (External value only)
+1 ; Pass - DFCP = Default FCP [optional]
+2 ;
+3 NEW DIC,DA
+4 if $DATA(DFCP)
SET DIC("B")=DFCP
+5 SET DA(1)=RMPOXITE
SET DIC("A")="Select FUND CONTROL POINT: "
+6 SET DIC="^RMPR(669.9,"_DA(1)_",""RMPOFCP"","
SET DIC(0)="AEQMZ"
DO ^DIC
+7 IF Y<0!$$QUIT
QUIT Y
+8 QUIT Y_U_Y(0,0)
QUIT() SET QUIT=$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT QUIT
EQUIT() SET QUIT=$DATA(DTOUT)!$DATA(Y)
QUIT QUIT
LJ(S,W,C) ; Left justify S in a field W wide padding with char F
+1 ;
+2 ; Default pad char is space
SET C=$GET(C," ")
+3 SET $PIECE(S,C,W-$LENGTH(S)+$LENGTH(S,C))=""
+4 QUIT $EXTRACT(S,1,W)
+5 QUIT
ENC(X,X1,X2) ;Encrypt
+1 ;Variable X = string to encrypt
+2 ; X1 = DUZ
+3 ; X2 = FCP IEN of file 665.72
+4 DO EN^XUSHSHP
+5 QUIT X
DEC(X,X1,X2) ;Decrypt
+1 ;Variable X = encrypted string
+2 ; X1 = DUZ
+3 ; X2 = FCP IEN of file 665.72
+4 DO DE^XUSHSHP
+5 QUIT X
