- 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 Feb 18, 2025@23:57:20 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