- PRCX1Q1 ;WISC/PLT-fill in fields 449, 450 of file 410 for carry forward ;4/23/96 13:55
- V ;;5.0;IFCAP;**55**;4/21/95
- QUIT ;invalid entry
- ;
- EN ;fill in field 449 and 450 of file 410
- N PRC,PRCRI,PRCA,PRCB,PRCC,PRCD,PRCE,PRCG,PRCH,PRCF,DMAX
- N A,B,X,Y
- 410 W @IOF D EN^DDIOL("This is for IFCAP patch PRC*5*55 to fill in new fields")
- D EN^DDIOL("449 & 450 of file 410 for fiscal year 95 only.")
- D EN^DDIOL("This routine also sets up file 410 entries for all fiscal year 95")
- D EN^DDIOL("PURCHASE ORDERS without 2237 requests"),EN^DDIOL(" ")
- Q1 D YN^PRC0A(.X,.Y,"Ready to run","O","NO")
- G:X["^"!(X="")!'Y EXIT
- D EN^DDIOL("Start convert file 410")
- S PRCRI(411)=0 F S PRCRI(411)=$O(^PRC(411,PRCRI(411))) QUIT:PRCRI(411)>999999!'PRCRI(411) D
- . S PRC("SITE")=$P($G(^PRC(411,PRCRI(411),0)),"^") QUIT:'PRC("SITE") D
- .. QUIT
- . S PRCB=PRC("SITE")_"-95-1"
- . S PRCD=PRCB,PRCB=PRC("SITE")_"-95~"
- . F S PRCD=$O(^PRCS(410,"B",PRCD)) QUIT:PRCD]PRCB!'PRCD S PRCRI(410)=$O(^(PRCD,0)) I PRCRI(410) S PRCE=$G(^PRCS(410,PRCRI(410),0)),A=$G(^(4)),B=$G(^(7)) D
- .. S PRCG=$P(PRCE,"^",2),PRCF=$P(PRCE,"^",4),PRCH="E"
- .. W !,$P(PRCE,"^")
- .. I PRCG="CA" S PRCH="C"
- .. I PRCG="C" S PRCH="O"
- .. I PRCG="O" S PRCH=$S($P(A,"^",10)]"":"O",$P(B,"^",6)]"":"A",1:"E") I PRCH="A",$P(A,"^",3)]"",+$P(A,"^",3)=0,$P(A,"^",5)]"" S PRCH="O" W " SECONDARY REQUEST"
- .. I PRCG="A" S PRCH="O" S:PRCF=1 PRCH=$S($P(A,"^",10)]"":"O",$P(B,"^",6)]"":"A",1:"E")
- .. ;D ERS410^PRC0G(PRCRI(410)_"^"_PRCH)
- .. I $P(PRCE,"^",12)="" D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"450///^S X=PRCH;449////"_$P($$QTRDATE^PRC0D($P(PRCE,"-",2),$P(PRCE,"-",3)),"^",7))
- .. S PRCE=$G(^PRCS(410,PRCRI(410),0))
- .. W ?20,$P(PRCE,"^",11),?30,$P(PRCE,"^",12)
- .. QUIT
- . QUIT
- ;
- D EN^DDIOL(" ")
- D EN^DDIOL("FILL-IN NEW FIELD 449 & 450 IN FILE 410 DONE")
- D EN^DDIOL(" ")
- 442 D EN^DDIOL("Start convert purchase orders without requests in file 442")
- S PRCB=2941000
- F S PRCB=$O(^PRC(442,"AB",PRCB)) QUIT:PRCB>2951000!'PRCB D
- . W !,PRCB
- . S PRCRI(442)="" F S PRCRI(442)=$O(^PRC(442,"AB",PRCB,PRCRI(442))) QUIT:'PRCRI(442) S PRCD=$G(^PRC(442,PRCRI(442),0)),PRCF=$P(PRCD,"^",2) I PRCF-22,PRCF-23,PRCF-24 D:$P($G(^(12)),"^",12)]""&($P($G(^(10,1,0)),"^",2)]"")
- .. W !,$P(PRCD,"^")
- .. I $P(PRCD,"^",12)]"" D QUIT
- ... N A,B
- ... S A=0 F S A=$O(^PRC(442,PRCRI(442),13,A)) QUIT:'A S PRCRI(410)=$P($G(^(A,0)),"^") I PRCRI(410) S PRCE=$G(^PRCS(410,PRCRI(410),0)) I PRCE,$P(PRCE,"^",12)=""!1 D W " REQUEST-"_PRCRI(410)
- .... D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"450////O;449////"_$P($$QTRDATE^PRC0D($P(PRCE,"-",2),$P(PRCE,"-",3)),"^",7))
- .... QUIT
- ... QUIT
- .. N PRCOBL,PRCOBD,PRCOBA
- .. N A,B,X,Y,Z
- .. W " WITHOUT REQUEST"
- .. S A=$P(PRCD,"^"),PRC("SITE")=$P(A,"-"),PRCOBL=$P(A,"-",2)_"WR"
- .. I $$DUP(PRC("SITE"),PRCOBL) W " *** DUPLICATE" QUIT
- .. S PRCOBD=$P(^PRC(442,PRCRI(442),1),"^",15)
- .. S PRCOBA=$P($G(^PRC(442,PRCRI(442),0)),"^",16) S:PRCOBA="" PRCOBA=0 S:$P($G(^PRC(442,PRCRI(442),7)),"^",2)=45 PRCOBA=0
- .. I $P($G(^PRC(442,PRCRI(442),0)),"^",2)=25 S PRCOBA=0
- .. I '$D(^PRCS(410.1,"B",$P(PRCD,"-")_"-"_$E($$DATE^PRC0C(PRCOBD,"I"),3,4)_"-"_$P($P(PRCD,"^",3)," "))) W !," MISSING SEQ#, NOT CONVERTED" QUIT
- .. D A410^PRC0F(.X,$P(PRCD,"-")_"^"_$P(PRCD,"^",3)_"^A^^"_PRCOBD_"^"_PRCOBA_"^"_PRCOBL)
- .. S PRCRI(410)=X I PRCRI(410) S PRCE=$G(^PRCS(410,PRCRI(410),0)) D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"449////"_$P($$QTRDATE^PRC0D($P(PRCE,"-",2),$P(PRCE,"-",3)),"^",7))
- .. QUIT
- . QUIT
- D EN^DDIOL("PURCHASE ORDERS WITHOUT REQUESTS DONE!")
- 417 I 0 D EN^DDIOL(""),EN^DDIOL("Start convert 820 transactions in file 417")
- I 0 S PRCRI(411)=0 F S PRCRI(411)=$O(^PRC(411,PRCRI(411))) QUIT:PRCRI(411)>999999!'PRCRI(411) D
- . S PRC("SITE")=$P($G(^PRC(411,PRCRI(411),0)),"^") QUIT:'PRC("SITE") D
- . S PRCB=PRC("SITE")_"-95-"
- . S PRCD=PRCB,PRCB=PRC("SITE")_"-~"
- . F S PRCD=$O(^PRCS(417,"C",PRCD)) QUIT:PRCD]PRCB!'PRCD W !,PRCD S PRCRI(417)="" F S PRCRI(417)=$O(^PRCS(417,"C",PRCD,PRCRI(417))) QUIT:'PRCRI(417) I PRCRI(417) S PRCE=$G(^PRCS(417,PRCRI(417),0)),PRCF=$P($G(^(1)),"^") D
- .. N PRCOBL,PRCOBD,PRCOBA
- .. N A,B,X,Y,Z
- .. S PRCOBA=$P(PRCE,"^",20),PRCOBD=$P($P(PRCE,"^",22),"."),PRCOBL=$P(PRCE,"^",18)_"_820"
- .. W !,PRCE
- .. I $G(PRCF) W " *** DUPLICATE" QUIT
- .. D A410^PRC0F(.X,$P(PRCD,"-")_"^"_$P(PRCD,"-",4)_"^A^^"_PRCOBD_"^"_PRCOBA_"^"_PRCOBL)
- .. S:X $P(^PRCS(417,PRCRI(417),1),"^")=X
- .. QUIT
- . QUIT
- ;D EN^DDIOL("820 FMS TRANSACTION DONE!")
- D EN^DDIOL("IFCAP PATCH *5*55 CONVERSION DONE FOR 1995!")
- D
- . N A,B,X,Y
- . S X(1)="IFCAP CARRY FORWARD CONVERSION FOR 1995 DONE! 1995 RUNNING BALNCE REPORT IS SET UP."
- . S Y(.5)="",Y(DUZ)=""
- . D MM^PRC0B2("IFCAP CARRY FORWARD CONVERSION FOR 1995 DONE!","X(",.Y)
- EXIT QUIT
- ;
- DUP(A,B) ;CHECK DUPLICATION FOR 442 CONVERSION
- N C,D,E
- S C=""
- S D="" F S D=$O(^PRCS(410,"D",B,D)) QUIT:'D I D,+$G(^PRCS(410,D,0))=+PRC("SITE") S C=1 QUIT
- QUIT C
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCX1Q1 4997 printed Mar 13, 2025@21:25:15 Page 2
- PRCX1Q1 ;WISC/PLT-fill in fields 449, 450 of file 410 for carry forward ;4/23/96 13:55
- V ;;5.0;IFCAP;**55**;4/21/95
- +1 ;invalid entry
- QUIT
- +2 ;
- EN ;fill in field 449 and 450 of file 410
- +1 NEW PRC,PRCRI,PRCA,PRCB,PRCC,PRCD,PRCE,PRCG,PRCH,PRCF,DMAX
- +2 NEW A,B,X,Y
- 410 WRITE @IOF
- DO EN^DDIOL("This is for IFCAP patch PRC*5*55 to fill in new fields")
- +1 DO EN^DDIOL("449 & 450 of file 410 for fiscal year 95 only.")
- +2 DO EN^DDIOL("This routine also sets up file 410 entries for all fiscal year 95")
- +3 DO EN^DDIOL("PURCHASE ORDERS without 2237 requests")
- DO EN^DDIOL(" ")
- Q1 DO YN^PRC0A(.X,.Y,"Ready to run","O","NO")
- +1 if X["^"!(X="")!'Y
- GOTO EXIT
- +2 DO EN^DDIOL("Start convert file 410")
- +3 SET PRCRI(411)=0
- FOR
- SET PRCRI(411)=$ORDER(^PRC(411,PRCRI(411)))
- if PRCRI(411)>999999!'PRCRI(411)
- QUIT
- Begin DoDot:1
- +4 SET PRC("SITE")=$PIECE($GET(^PRC(411,PRCRI(411),0)),"^")
- if 'PRC("SITE")
- QUIT
- Begin DoDot:2
- +5 QUIT
- End DoDot:2
- +6 SET PRCB=PRC("SITE")_"-95-1"
- +7 SET PRCD=PRCB
- SET PRCB=PRC("SITE")_"-95~"
- +8 FOR
- SET PRCD=$ORDER(^PRCS(410,"B",PRCD))
- if PRCD]PRCB!'PRCD
- QUIT
- SET PRCRI(410)=$ORDER(^(PRCD,0))
- IF PRCRI(410)
- SET PRCE=$GET(^PRCS(410,PRCRI(410),0))
- SET A=$GET(^(4))
- SET B=$GET(^(7))
- Begin DoDot:2
- +9 SET PRCG=$PIECE(PRCE,"^",2)
- SET PRCF=$PIECE(PRCE,"^",4)
- SET PRCH="E"
- +10 WRITE !,$PIECE(PRCE,"^")
- +11 IF PRCG="CA"
- SET PRCH="C"
- +12 IF PRCG="C"
- SET PRCH="O"
- +13 IF PRCG="O"
- SET PRCH=$SELECT($PIECE(A,"^",10)]"":"O",$PIECE(B,"^",6)]"":"A",1:"E")
- IF PRCH="A"
- IF $PIECE(A,"^",3)]""
- IF +$PIECE(A,"^",3)=0
- IF $PIECE(A,"^",5)]""
- SET PRCH="O"
- WRITE " SECONDARY REQUEST"
- +14 IF PRCG="A"
- SET PRCH="O"
- if PRCF=1
- SET PRCH=$SELECT($PIECE(A,"^",10)]"":"O",$PIECE(B,"^",6)]"":"A",1:"E")
- +15 ;D ERS410^PRC0G(PRCRI(410)_"^"_PRCH)
- +16 IF $PIECE(PRCE,"^",12)=""
- DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"450///^S X=PRCH;449////"_$PIECE($$QTRDATE^PRC0D($PIECE(PRCE,"-",2),$PIECE(PRCE,"-",3)),"^",7))
- +17 SET PRCE=$GET(^PRCS(410,PRCRI(410),0))
- +18 WRITE ?20,$PIECE(PRCE,"^",11),?30,$PIECE(PRCE,"^",12)
- +19 QUIT
- End DoDot:2
- +20 QUIT
- End DoDot:1
- +21 ;
- +22 DO EN^DDIOL(" ")
- +23 DO EN^DDIOL("FILL-IN NEW FIELD 449 & 450 IN FILE 410 DONE")
- +24 DO EN^DDIOL(" ")
- 442 DO EN^DDIOL("Start convert purchase orders without requests in file 442")
- +1 SET PRCB=2941000
- +2 FOR
- SET PRCB=$ORDER(^PRC(442,"AB",PRCB))
- if PRCB>2951000!'PRCB
- QUIT
- Begin DoDot:1
- +3 WRITE !,PRCB
- +4 SET PRCRI(442)=""
- FOR
- SET PRCRI(442)=$ORDER(^PRC(442,"AB",PRCB,PRCRI(442)))
- if 'PRCRI(442)
- QUIT
- SET PRCD=$GET(^PRC(442,PRCRI(442),0))
- SET PRCF=$PIECE(PRCD,"^",2)
- IF PRCF-22
- IF PRCF-23
- IF PRCF-24
- if $PIECE($GET(^(12)),"^",12)]""&($PIECE($GET(^(10,1,0)),"^",2)]"")
- Begin DoDot:2
- +5 WRITE !,$PIECE(PRCD,"^")
- +6 IF $PIECE(PRCD,"^",12)]""
- Begin DoDot:3
- +7 NEW A,B
- +8 SET A=0
- FOR
- SET A=$ORDER(^PRC(442,PRCRI(442),13,A))
- if 'A
- QUIT
- SET PRCRI(410)=$PIECE($GET(^(A,0)),"^")
- IF PRCRI(410)
- SET PRCE=$GET(^PRCS(410,PRCRI(410),0))
- IF PRCE
- IF $PIECE(PRCE,"^",12)=""!1
- Begin DoDot:4
- +9 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"450////O;449////"_$PIECE($$QTRDATE^PRC0D($PIECE(PRCE,"-",2),$PIECE(PRCE,"-",3)),"^",7))
- +10 QUIT
- End DoDot:4
- WRITE " REQUEST-"_PRCRI(410)
- +11 QUIT
- End DoDot:3
- QUIT
- +12 NEW PRCOBL,PRCOBD,PRCOBA
- +13 NEW A,B,X,Y,Z
- +14 WRITE " WITHOUT REQUEST"
- +15 SET A=$PIECE(PRCD,"^")
- SET PRC("SITE")=$PIECE(A,"-")
- SET PRCOBL=$PIECE(A,"-",2)_"WR"
- +16 IF $$DUP(PRC("SITE"),PRCOBL)
- WRITE " *** DUPLICATE"
- QUIT
- +17 SET PRCOBD=$PIECE(^PRC(442,PRCRI(442),1),"^",15)
- +18 SET PRCOBA=$PIECE($GET(^PRC(442,PRCRI(442),0)),"^",16)
- if PRCOBA=""
- SET PRCOBA=0
- if $PIECE($GET(^PRC(442,PRCRI(442),7)),"^",2)=45
- SET PRCOBA=0
- +19 IF $PIECE($GET(^PRC(442,PRCRI(442),0)),"^",2)=25
- SET PRCOBA=0
- +20 IF '$DATA(^PRCS(410.1,"B",$PIECE(PRCD,"-")_"-"_$EXTRACT($$DATE^PRC0C(PRCOBD,"I"),3,4)_"-"_$PIECE($PIECE(PRCD,"^",3)," ")))
- WRITE !," MISSING SEQ#, NOT CONVERTED"
- QUIT
- +21 DO A410^PRC0F(.X,$PIECE(PRCD,"-")_"^"_$PIECE(PRCD,"^",3)_"^A^^"_PRCOBD_"^"_PRCOBA_"^"_PRCOBL)
- +22 SET PRCRI(410)=X
- IF PRCRI(410)
- SET PRCE=$GET(^PRCS(410,PRCRI(410),0))
- DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"449////"_$PIECE($$QTRDATE^PRC0D($PIECE(PRCE,"-",2),$PIECE(PRCE,"-",3)),"^",7))
- +23 QUIT
- End DoDot:2
- +24 QUIT
- End DoDot:1
- +25 DO EN^DDIOL("PURCHASE ORDERS WITHOUT REQUESTS DONE!")
- 417 IF 0
- DO EN^DDIOL("")
- DO EN^DDIOL("Start convert 820 transactions in file 417")
- +1 IF 0
- SET PRCRI(411)=0
- FOR
- SET PRCRI(411)=$ORDER(^PRC(411,PRCRI(411)))
- if PRCRI(411)>999999!'PRCRI(411)
- QUIT
- Begin DoDot:1
- +2 SET PRC("SITE")=$PIECE($GET(^PRC(411,PRCRI(411),0)),"^")
- if 'PRC("SITE")
- QUIT
- Begin DoDot:2
- End DoDot:2
- +3 SET PRCB=PRC("SITE")_"-95-"
- +4 SET PRCD=PRCB
- SET PRCB=PRC("SITE")_"-~"
- +5 FOR
- SET PRCD=$ORDER(^PRCS(417,"C",PRCD))
- if PRCD]PRCB!'PRCD
- QUIT
- WRITE !,PRCD
- SET PRCRI(417)=""
- FOR
- SET PRCRI(417)=$ORDER(^PRCS(417,"C",PRCD,PRCRI(417)))
- if 'PRCRI(417)
- QUIT
- IF PRCRI(417)
- SET PRCE=$GET(^PRCS(417,PRCRI(417),0))
- SET PRCF=$PIECE($GET(^(1)),"^")
- Begin DoDot:2
- +6 NEW PRCOBL,PRCOBD,PRCOBA
- +7 NEW A,B,X,Y,Z
- +8 SET PRCOBA=$PIECE(PRCE,"^",20)
- SET PRCOBD=$PIECE($PIECE(PRCE,"^",22),".")
- SET PRCOBL=$PIECE(PRCE,"^",18)_"_820"
- +9 WRITE !,PRCE
- +10 IF $GET(PRCF)
- WRITE " *** DUPLICATE"
- QUIT
- +11 DO A410^PRC0F(.X,$PIECE(PRCD,"-")_"^"_$PIECE(PRCD,"-",4)_"^A^^"_PRCOBD_"^"_PRCOBA_"^"_PRCOBL)
- +12 if X
- SET $PIECE(^PRCS(417,PRCRI(417),1),"^")=X
- +13 QUIT
- End DoDot:2
- +14 QUIT
- End DoDot:1
- +15 ;D EN^DDIOL("820 FMS TRANSACTION DONE!")
- +16 DO EN^DDIOL("IFCAP PATCH *5*55 CONVERSION DONE FOR 1995!")
- +17 Begin DoDot:1
- +18 NEW A,B,X,Y
- +19 SET X(1)="IFCAP CARRY FORWARD CONVERSION FOR 1995 DONE! 1995 RUNNING BALNCE REPORT IS SET UP."
- +20 SET Y(.5)=""
- SET Y(DUZ)=""
- +21 DO MM^PRC0B2("IFCAP CARRY FORWARD CONVERSION FOR 1995 DONE!","X(",.Y)
- End DoDot:1
- EXIT QUIT
- +1 ;
- DUP(A,B) ;CHECK DUPLICATION FOR 442 CONVERSION
- +1 NEW C,D,E
- +2 SET C=""
- +3 SET D=""
- FOR
- SET D=$ORDER(^PRCS(410,"D",B,D))
- if 'D
- QUIT
- IF D
- IF +$GET(^PRCS(410,D,0))=+PRC("SITE")
- SET C=1
- QUIT
- +4 QUIT C
