- PRCFDBL ;WISC/CLH/LEM-BULLETIN GENERATOR FOR CI'S DUE ;7/19/95 14:30
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- N PRC,X,Y,%,DIR,PRCFDT,DATE
- S X="T+7" D ^%DT S PRCFDT=Y D DD^%DT S DATE=Y
- I '$D(ZTQUEUED) D Q
- . S PRCF("X")="AS" D ^PRCFSITE Q:'%
- . W ! S DIR(0)="Y",DIR("T")=120,DIR("A")="Okay to continue",DIR("A",1)="This option generates bulletins to those services having",DIR("A",2)="a Certified Invoice due in Fiscal on "_DATE_".",DIR("?")="^D CI^PRCFHLP"
- . S DIR("A",3)=" ",DIR("A",4)="This job is scheduled to run on a daily basis",DIR("A",5)="Are you sure you want to run this option manually?" D ^DIR K DIR
- . I 'Y Q
- . S ZTDTH=$H,ZTIO="",ZTDESC="Certified Invoice Bulletin Generator",ZTRTN="DQ^PRCFDBL",ZTSAVE("PRC*")="",ZTSAVE("DATE")="" D ^%ZTLOAD
- . W !! S X="Request Queued.*" D MSG^PRCFQ K ZTSK
- DQ N DA,CP,XMY,XMDUZ,XMTEXT,MSG,SITE,FCP,FCPTR,PRCFPO,X,ZX,ZXX,CNT,XMZ
- K ^TMP($J) Q:'$D(^PRCF(421.5,"AC",PRCFDT))
- S DA=0 F S DA=$O(^PRCF(421.5,"AC",PRCFDT,DA)) Q:'DA I $D(^PRCF(421.5,DA,2)),'$P(^(2),U,14) D
- . S PRC("SITE")=+$P(^PRCF(421.5,DA,2),U,3)
- . S FCPTR=$P($G(^PRCF(421.5,DA,0)),U,7) Q:'FCPTR
- . S FCP=+$P($G(^PRC(442,FCPTR,0)),U,3) Q:'FCP
- . S ^TMP($J,PRC("SITE"),FCP,DA)=""
- S PRC("SITE")=0
- F S PRC("SITE")=$O(^TMP($J,PRC("SITE"))) Q:'PRC("SITE") D
- . S FCP=0 F S FCP=$O(^TMP($J,PRC("SITE"),FCP)) Q:'FCP D
- . . S MSG(1)=" "
- . . S MSG(2)="The following invoice(s) are DUE in Fiscal on "_DATE
- . . S MSG(3)=" for Control Point "_$S($D(^PRC(420,PRC("SITE"),1,+FCP,0)):$P(^(0),U),1:"UNKNOWN FCP")_":"
- . . S MSG(4)=" "
- . . S CNT=4,DA=0 F S DA=$O(^TMP($J,PRC("SITE"),FCP,DA)) Q:'DA D
- . . . S CNT=CNT+1,X=^PRCF(421.5,DA,0),MSG(CNT)="Tracking #: "
- . . . S MSG(CNT)=MSG(CNT)_$P(X,U)_", Vendor: "
- . . . S MSG(CNT)=MSG(CNT)_$S($P(X,U,8)]"":$P($G(^PRC(440,$P(X,U,8),0)),U),1:"UNKNOWN")
- . . . S MSG(CNT)=MSG(CNT)_", Invoice #: "_$P(X,U,3)
- . . . S PRCFPO=$P($G(^PRCF(421.5,DA,1)),U,3)
- . . . S:PRCFPO]"" MSG(CNT)=MSG(CNT)_", PO#: "_PRCFPO
- . . . Q
- . . K XMY S ZX=0 F S ZX=$O(^PRC(420,PRC("SITE"),1,+FCP,1,ZX)) Q:'ZX I $P($G(^(ZX,0)),U,2)<3,$P(^(0),"^")]"" S XMY(ZX)=""
- . . S XMDUZ=$S(+$G(PRC("PER")):+PRC("PER"),1:DUZ),XMY(XMDUZ)=""
- . . S XMSUB="CERTIFIED INVOICES DUE IN FISCAL",XMTEXT="MSG("
- . . S MSG(CNT+1)=" "
- . . S MSG(CNT+2)="Please note and return to Fiscal prior to due date."
- . . D ^XMD
- . . S ZXX=0 F S ZXX=$O(^TMP($J,PRC("SITE"),FCP,ZXX)) Q:'ZXX S $P(^PRCF(421.5,ZXX,2),U,14)=1,$P(^(2),U,15)=DT,$P(^(2),U,16)=$G(XMZ)
- . . K MSG,XMY
- . . Q
- . Q
- S ZTREQ="@" K PRC,^TMP($J),DTOUT,DUOUT,DIRUT,DIROUT,PRCFDT,DATE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDBL 2662 printed Mar 13, 2025@21:07:39 Page 2
- PRCFDBL ;WISC/CLH/LEM-BULLETIN GENERATOR FOR CI'S DUE ;7/19/95 14:30
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW PRC,X,Y,%,DIR,PRCFDT,DATE
- +3 SET X="T+7"
- DO ^%DT
- SET PRCFDT=Y
- DO DD^%DT
- SET DATE=Y
- +4 IF '$DATA(ZTQUEUED)
- Begin DoDot:1
- +5 SET PRCF("X")="AS"
- DO ^PRCFSITE
- if '%
- QUIT
- +6 WRITE !
- SET DIR(0)="Y"
- SET DIR("T")=120
- SET DIR("A")="Okay to continue"
- SET DIR("A",1)="This option generates bulletins to those services having"
- SET DIR("A",2)="a Certified Invoice due in Fiscal on "_DATE_"."
- SET DIR("?")="^D CI^PRCFHLP"
- +7 SET DIR("A",3)=" "
- SET DIR("A",4)="This job is scheduled to run on a daily basis"
- SET DIR("A",5)="Are you sure you want to run this option manually?"
- DO ^DIR
- KILL DIR
- +8 IF 'Y
- QUIT
- +9 SET ZTDTH=$HOROLOG
- SET ZTIO=""
- SET ZTDESC="Certified Invoice Bulletin Generator"
- SET ZTRTN="DQ^PRCFDBL"
- SET ZTSAVE("PRC*")=""
- SET ZTSAVE("DATE")=""
- DO ^%ZTLOAD
- +10 WRITE !!
- SET X="Request Queued.*"
- DO MSG^PRCFQ
- KILL ZTSK
- End DoDot:1
- QUIT
- DQ NEW DA,CP,XMY,XMDUZ,XMTEXT,MSG,SITE,FCP,FCPTR,PRCFPO,X,ZX,ZXX,CNT,XMZ
- +1 KILL ^TMP($JOB)
- if '$DATA(^PRCF(421.5,"AC",PRCFDT))
- QUIT
- +2 SET DA=0
- FOR
- SET DA=$ORDER(^PRCF(421.5,"AC",PRCFDT,DA))
- if 'DA
- QUIT
- IF $DATA(^PRCF(421.5,DA,2))
- IF '$PIECE(^(2),U,14)
- Begin DoDot:1
- +3 SET PRC("SITE")=+$PIECE(^PRCF(421.5,DA,2),U,3)
- +4 SET FCPTR=$PIECE($GET(^PRCF(421.5,DA,0)),U,7)
- if 'FCPTR
- QUIT
- +5 SET FCP=+$PIECE($GET(^PRC(442,FCPTR,0)),U,3)
- if 'FCP
- QUIT
- +6 SET ^TMP($JOB,PRC("SITE"),FCP,DA)=""
- End DoDot:1
- +7 SET PRC("SITE")=0
- +8 FOR
- SET PRC("SITE")=$ORDER(^TMP($JOB,PRC("SITE")))
- if 'PRC("SITE")
- QUIT
- Begin DoDot:1
- +9 SET FCP=0
- FOR
- SET FCP=$ORDER(^TMP($JOB,PRC("SITE"),FCP))
- if 'FCP
- QUIT
- Begin DoDot:2
- +10 SET MSG(1)=" "
- +11 SET MSG(2)="The following invoice(s) are DUE in Fiscal on "_DATE
- +12 SET MSG(3)=" for Control Point "_$SELECT($DATA(^PRC(420,PRC("SITE"),1,+FCP,0)):$PIECE(^(0),U),1:"UNKNOWN FCP")_":"
- +13 SET MSG(4)=" "
- +14 SET CNT=4
- SET DA=0
- FOR
- SET DA=$ORDER(^TMP($JOB,PRC("SITE"),FCP,DA))
- if 'DA
- QUIT
- Begin DoDot:3
- +15 SET CNT=CNT+1
- SET X=^PRCF(421.5,DA,0)
- SET MSG(CNT)="Tracking #: "
- +16 SET MSG(CNT)=MSG(CNT)_$PIECE(X,U)_", Vendor: "
- +17 SET MSG(CNT)=MSG(CNT)_$SELECT($PIECE(X,U,8)]"":$PIECE($GET(^PRC(440,$PIECE(X,U,8),0)),U),1:"UNKNOWN")
- +18 SET MSG(CNT)=MSG(CNT)_", Invoice #: "_$PIECE(X,U,3)
- +19 SET PRCFPO=$PIECE($GET(^PRCF(421.5,DA,1)),U,3)
- +20 if PRCFPO]""
- SET MSG(CNT)=MSG(CNT)_", PO#: "_PRCFPO
- +21 QUIT
- End DoDot:3
- +22 KILL XMY
- SET ZX=0
- FOR
- SET ZX=$ORDER(^PRC(420,PRC("SITE"),1,+FCP,1,ZX))
- if 'ZX
- QUIT
- IF $PIECE($GET(^(ZX,0)),U,2)<3
- IF $PIECE(^(0),"^")]""
- SET XMY(ZX)=""
- +23 SET XMDUZ=$SELECT(+$GET(PRC("PER")):+PRC("PER"),1:DUZ)
- SET XMY(XMDUZ)=""
- +24 SET XMSUB="CERTIFIED INVOICES DUE IN FISCAL"
- SET XMTEXT="MSG("
- +25 SET MSG(CNT+1)=" "
- +26 SET MSG(CNT+2)="Please note and return to Fiscal prior to due date."
- +27 DO ^XMD
- +28 SET ZXX=0
- FOR
- SET ZXX=$ORDER(^TMP($JOB,PRC("SITE"),FCP,ZXX))
- if 'ZXX
- QUIT
- SET $PIECE(^PRCF(421.5,ZXX,2),U,14)=1
- SET $PIECE(^(2),U,15)=DT
- SET $PIECE(^(2),U,16)=$GET(XMZ)
- +29 KILL MSG,XMY
- +30 QUIT
- End DoDot:2
- +31 QUIT
- End DoDot:1
- +32 SET ZTREQ="@"
- KILL PRC,^TMP($JOB),DTOUT,DUOUT,DIRUT,DIROUT,PRCFDT,DATE
- +33 QUIT
