- PRCSP1F ;SF-ISC/LJP-PRINT COMPLETED PO LIST FOR SCP $ RECONCILIATION ;3/19/91 16:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D EN^PRCSUT G W2^PRCSP1B:'$D(PRC("SITE")),EXIT^PRCSP1B:Y<0 S PRCSZZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
- S L=0,DIC="^PRCS(410,",FLDS="[PRCSCSCP]",BY="@.01,54",FR=PRCSZZ_"-0001,",TO=PRCSZZ_"-9999,",DHD="PO/SCP $ RECONCILIATION"_" "_+PRC("CP")_"-"_PRC("FY")_"-"_PRC("QTR")
- ;S DIS(0)="I $D(D0),$D(^PRCS(410,D0,10)) S ZX=+$P(^(10),U,4) I ZX=$O(^PRCD(442.3,""C"",20,0))!(ZX=$O(^PRCD(442.3,""AC"",100,0)))!(ZX=$O(^PRCD(442.3,""C"",21,0)))"
- D EN1^DIP K DHD,DIS(0),BY,FR,TO,FLDS,PRCSZZ,ZX Q
- OPN ;LIST OF OPEN (INCOMPLETE) 1358'S
- D EN^PRCSUT G W2^PRCSP1B:'$D(PRC("SITE")),EXIT^PRCSP1B:Y<0 S PRCSZZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
- S DHD="OPEN 1358 DAILY RECORDS",L=0,DIC="^PRC(424,"
- S FLDS=".01,.05,.1",BY="[PRCEC OPN1358]",(FR,TO)="",DIS(0)="I $P($G(^PRC(424,D0,0)),""-"")=PRC(""SITE""),$P($G(^PRC(424,D0,0)),U,2),+$P($G(^PRC(442,$P(^(0),U,2),0)),U,3)=+PRC(""CP"")"
- D EN1^DIP K PRCSZZ,DHD,L,DIC,FLDS,BY,FR,TO Q
- MDL ;MULTIPLE DELIVERY SCHEDULE LIST
- D EN3^PRCSUT G W2^PRCSEB0:'$D(PRC("SITE")),EXIT^PRCSEB0:Y<0
- S DIC="^PRCS(410,",DIC(0)="AEMQZ",DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^PRCS(410,+Y,0),U,5)=PRC(""SITE""),$O(^PRCS(410,+Y,""IT"",1,2,0))" D ^PRCSDIC K DIC("S") I Y<0 K DIC Q
- S L=0,FLDS="[PRCSMDS]",BY="@NUMBER",(FR,TO)=+Y D EN1^DIP K L,FLDS,BY,FR,TO Q
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP1F 1530 printed Feb 18, 2025@23:44:34 Page 2
- PRCSP1F ;SF-ISC/LJP-PRINT COMPLETED PO LIST FOR SCP $ RECONCILIATION ;3/19/91 16:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 DO EN^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2^PRCSP1B
- if Y<0
- GOTO EXIT^PRCSP1B
- SET PRCSZZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
- +3 SET L=0
- SET DIC="^PRCS(410,"
- SET FLDS="[PRCSCSCP]"
- SET BY="@.01,54"
- SET FR=PRCSZZ_"-0001,"
- SET TO=PRCSZZ_"-9999,"
- SET DHD="PO/SCP $ RECONCILIATION"_" "_+PRC("CP")_"-"_PRC("FY")_"-"_PRC("QTR")
- +4 ;S DIS(0)="I $D(D0),$D(^PRCS(410,D0,10)) S ZX=+$P(^(10),U,4) I ZX=$O(^PRCD(442.3,""C"",20,0))!(ZX=$O(^PRCD(442.3,""AC"",100,0)))!(ZX=$O(^PRCD(442.3,""C"",21,0)))"
- +5 DO EN1^DIP
- KILL DHD,DIS(0),BY,FR,TO,FLDS,PRCSZZ,ZX
- QUIT
- OPN ;LIST OF OPEN (INCOMPLETE) 1358'S
- +1 DO EN^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2^PRCSP1B
- if Y<0
- GOTO EXIT^PRCSP1B
- SET PRCSZZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
- +2 SET DHD="OPEN 1358 DAILY RECORDS"
- SET L=0
- SET DIC="^PRC(424,"
- +3 SET FLDS=".01,.05,.1"
- SET BY="[PRCEC OPN1358]"
- SET (FR,TO)=""
- SET DIS(0)="I $P($G(^PRC(424,D0,0)),""-"")=PRC(""SITE""),$P($G(^PRC(424,D0,0)),U,2),+$P($G(^PRC(442,$P(^(0),U,2),0)),U,3)=+PRC(""CP"")"
- +4 DO EN1^DIP
- KILL PRCSZZ,DHD,L,DIC,FLDS,BY,FR,TO
- QUIT
- MDL ;MULTIPLE DELIVERY SCHEDULE LIST
- +1 DO EN3^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2^PRCSEB0
- if Y<0
- GOTO EXIT^PRCSEB0
- +2 SET DIC="^PRCS(410,"
- SET DIC(0)="AEMQZ"
- SET DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^PRCS(410,+Y,0),U,5)=PRC(""SITE""),$O(^PRCS(410,+Y,""IT"",1,2,0))"
- DO ^PRCSDIC
- KILL DIC("S")
- IF Y<0
- KILL DIC
- QUIT
- +3 SET L=0
- SET FLDS="[PRCSMDS]"
- SET BY="@NUMBER"
- SET (FR,TO)=+Y
- DO EN1^DIP
- KILL L,FLDS,BY,FR,TO
- QUIT
- +4 ;
- +5 QUIT
