Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPOPST2

RMPOPST2.m

Go to the documentation of this file. 
  1. RMPOPST2 ;EDS/JAM - HOME OXYGEN BILLING TRANSACTIONS/POSTING - SIGN OFF ;7/24/98
  1.  ;;3.0;PROSTHETICS;**29,44**;Feb 09, 1996
  1.  ;
  1.  ;This subroutine is part of the billing module. Purchase Card
  1.  ;orders are obligated and 1358 serivce orders are closed.  
  1.  ;The ^RMPO(665.72 global is updated with the date closed and user.
  1.  Q
  1. MAIN ; Proper entry point
  1.  D HOME^%ZIS
  1.  S QUIT=0
  1.  D HOSITE^RMPOUTL0 Q:('$D(RMPOREC))!QUIT
  1.  S RMPOXITE=RMPOREC
  1.  D MONTH^RMPOBIL0() Q:'$D(RMPODATE)!QUIT
  1.  ;D VENDOR^RMPOBIL0 Q:'$D(RMPOVDR)!QUIT
  1.  D SIGNOF,EXIT
  1.  Q
  1. TEST ;set test data
  1.  S RMPOXITE=1,RMPORVDT=7019199,RMPOVDR=10,RMPODATE=2980800,DFNS(47)=""
  1.  S RMPO("STA")=521 N XQY0
  1.  S XQY0="RMPO BILLING TRANSACTIONS^Billing Transactions^^R^547^^^^^^^341^^^"
  1.  ;
  1. SIGNOF ;Sign off/close a FCP/purchase order
  1.  ;Determine payment type;if PC obligate & close;if 1358 close
  1.  N SITE,RVDT,FIL,PFLG,FCPTOT,REFNO,IEN442,FCP,IENFCP,PAYTYP,LCK,X,Y
  1.  S FIL=665.72,SITE=RMPOXITE,RVDT=RMPODATE ;,VDR=RMPOVDR
  1.  D PTYP I Y<0!(Y="")!(Y="^") D ABORT Q
  1.  S PAYTYP=Y D FCP I Y'>0 D ABORT Q
  1.  S IENFCP=+Y,FCP=$P(Y(0),U),IEN442=$P(Y(0),U,3),REFNO=$P(Y(0),U,4)
  1.  S FCPTOT=$P(Y(0),U,7)
  1.  S PFLG=0 D FILCHK I PFLG D  I 'Y D ABORT Q
  1.  . S DIR(0)="Y"
  1.  . S DIR("A")="All Records not posted for "_FCP_" Continue" D ^DIR
  1.  ;Lock record at FCP level in ^RMPO(665.72
  1.  S LCK=$$FCPLCK^RMPOPST0 I 'LCK D  Q
  1.  . W !!,"Record in Use.  Try Later...."
  1.  D  I 'Y D ABORT G UNLK ;verify user is ready to close FCP
  1.  . S DIR(0)="Y"
  1.  . S DIR("A")="Sure you want to Continue" D ^DIR
  1.  D @$S(PAYTYP:"FCPUPD",1:"PCSO")
  1.  ;Unlock record at FCP in ^RMPO(665.72
  1. UNLK D UNLKFCP^RMPOPST0
  1.  Q  ;SIGNOF
  1.  ;
  1. ABORT ;Write abort message
  1.  W !!,"Process Aborted..."
  1.  Q
  1.  ;
  1. PTYP ;Select Payment Type; 1358 or purchase card
  1.  K DIC,DA,DR
  1.  D FCP1^RMPOBILU
  1.  Q  ;PTYP
  1. FCP ;Select Fund Control Point/Purchase Order to Sign Off
  1.  K DIC,DA,DR
  1.  S DA(1)=RVDT,DA(2)=SITE,DIC="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",2,"
  1.  S DIC(0)="QAEZ"
  1.  D
  1.  . I PAYTYP S DIC("S")="I $P(^(0),U,2)=PAYTYP,$P(^(0),U,8)=""""" Q
  1.  . ;S DIC("S")="I $P(^(0),U,2)=PAYTYP,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=VDR,$P(^(0),U,8)="""""
  1.  . S DIC("S")="I $P(^(0),U,2)=PAYTYP,$P(^(0),U,5)=DUZ,$P(^(0),U,8)="""""
  1.  S DIC("W")="W ?35,$P(^(0),U,2),"
  1.  S DIC("W")=DIC("W")_"$P(^(0),U,4)"
  1.  D ^DIC
  1.  I Y<0 W "  Nothing Found..."
  1.  Q  ;FCP
  1. FCPUPD ;Close FCP record in ^RMPO(665.72 file. Update global with date closed
  1.  ;and user for 1358 purchase order
  1.  K DIE,DA,DR
  1.  D NOW^%DTC
  1.  S DA=IENFCP,DA(1)=RVDT,DA(2)=SITE
  1.  S DIE="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",2,"
  1.  S DR="4////"_DUZ_";"_"7///"_%
  1.  D ^DIE
  1.  Q  ;FCPUPD
  1.  ;
  1. PCSO ;Obligate/Sign off PC order
  1.  N PRCA,PRCB,PRCC
  1.  S PRCA="",PRCB=IEN442
  1.  S PRCC=FCPTOT
  1.  D OBL^PRCH7D(.X,PRCA,PRCB,PRCC)
  1.  I X="^" D  Q  ;not obligated
  1.  . W !!,"Purchase Card Order "_REFNO
  1.  . W " Not Obligated for "_FCP
  1.  D FCPUPD
  1.  Q  ;PCSO
  1.  ;
  1. FILCHK ;Check records to enure all posting done before obligating for a FCP
  1.  ;PFLG 1-found record not posted, 0-all record posted
  1.  N DFN,IT,ITDT,VDR
  1.  W !!,"Verifying all items posted for FCP. Please be patient."
  1.  S VDR=0
  1.  F  S VDR=$O(^RMPO(FIL,SITE,1,RVDT,1,VDR)) Q:'VDR  D  I PFLG Q
  1.  . S DFN=0
  1.  . F  S DFN=$O(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN)) Q:'DFN  D  I PFLG Q
  1.  . . I $P(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,0),U,3)="Y" Q
  1.  . . S IT=0
  1.  . . F  S IT=$O(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT)) Q:'IT  D  Q:PFLG
  1.  . . . S ITDT=^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT,0) W "."
  1.  . . . I $P(ITDT,U,3)=FCP D
  1.  . . . . I $P(ITDT,U,10)'="Y",$P(ITDT,U,6)'=$P(ITDT,U,11) S PFLG=1
  1.  Q  ;FILCHK
  1. EXIT ;Kill variables
  1.  K DA,DIC,DIR,RMPO,QUIT,X,Y,RMPODATE,RMPOMTH,RMPOREC,RMPORVDT
  1.  Q