PRCX1Q ;WISC/PLT-fill in fields 449, 450 of file 410 for carry forward ;
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
;D EN^DDIOL("Recompile the input templates 'PRCH2138' and 'PRCHNREQ'.")
;S DMAX=4500,X="PRCHT1",Y=$O(^DIE("B","PRCH2138","")) I Y D EN^DIEZ
;S DMAX=4500,X="PRCHT3",Y=$O(^DIE("B","PRCHNREQ","")) I Y D EN^DIEZ
;D EN^DDIOL("Recompile the input templates 'PRCH2138' and 'PRCHNREQ' DONE!")
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 96 and future years requests only.")
D EN^DDIOL("This routine also sets up file 410 entries for all fiscal year 96 and future")
D EN^DDIOL("PURCHASE ORDERS without 2237 requests"),EN^DDIOL(" ")
I $D(ZTQUEUED) D EN^DDIOL(" "),EN^DDIOL(" You cannot queue this conversion. You need to run the conversion"),EN^DDIOL(" for 1996 by typing 'D ^XUP,EN^PRCX1Q' on your CRT-TERMINAL.") QUIT
Q1 D YN^PRC0A(.X,.Y,"Ready to run","O","YES")
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
.. D EDIT^PRC0B(.X,"420;^PRC(420,;"_PRCRI(411),"9///^S X=""10/1/95""","SL")
.. QUIT
. S PRCB=PRC("SITE")_"-96-1"
. S PRCD=PRCB,PRCB=PRC("SITE")_"-~"
. 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)
.. 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=2951000
F S PRCB=$O(^PRC(442,"AB",PRCB)) QUIT:'PRCB D
. 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 B=$P($G(^(A,0)),"^") I B D ERS410^PRC0G(B_"^O") W " REQUEST-"_B
... 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)
.. QUIT
. QUIT
D EN^DDIOL("PURCHASE ORDERS WITHOUT REQUESTS DONE!")
G EXIT
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")_"-96-"
. 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!")
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[HPRCX1Q 4795 printed Dec 13, 2024@02:20:26 Page 2
PRCX1Q ;WISC/PLT-fill in fields 449, 450 of file 410 for carry forward ;
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
+3 ;D EN^DDIOL("Recompile the input templates 'PRCH2138' and 'PRCHNREQ'.")
+4 ;S DMAX=4500,X="PRCHT1",Y=$O(^DIE("B","PRCH2138","")) I Y D EN^DIEZ
+5 ;S DMAX=4500,X="PRCHT3",Y=$O(^DIE("B","PRCHNREQ","")) I Y D EN^DIEZ
+6 ;D EN^DDIOL("Recompile the input templates 'PRCH2138' and 'PRCHNREQ' DONE!")
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 96 and future years requests only.")
+2 DO EN^DDIOL("This routine also sets up file 410 entries for all fiscal year 96 and future")
+3 DO EN^DDIOL("PURCHASE ORDERS without 2237 requests")
DO EN^DDIOL(" ")
+4 IF $DATA(ZTQUEUED)
DO EN^DDIOL(" ")
DO EN^DDIOL(" You cannot queue this conversion. You need to run the conversion")
DO EN^DDIOL(" for 1996 by typing 'D ^XUP,EN^PRCX1Q' on your CRT-TERMINAL.")
QUIT
Q1 DO YN^PRC0A(.X,.Y,"Ready to run","O","YES")
+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 DO EDIT^PRC0B(.X,"420;^PRC(420,;"_PRCRI(411),"9///^S X=""10/1/95""","SL")
+6 QUIT
End DoDot:2
+7 SET PRCB=PRC("SITE")_"-96-1"
+8 SET PRCD=PRCB
SET PRCB=PRC("SITE")_"-~"
+9 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
+10 SET PRCG=$PIECE(PRCE,"^",2)
SET PRCF=$PIECE(PRCE,"^",4)
SET PRCH="E"
+11 WRITE !,$PIECE(PRCE,"^")
+12 IF PRCG="CA"
SET PRCH="C"
+13 IF PRCG="C"
SET PRCH="O"
+14 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"
+15 IF PRCG="A"
SET PRCH="O"
if PRCF=1
SET PRCH=$SELECT($PIECE(A,"^",10)]"":"O",$PIECE(B,"^",6)]"":"A",1:"E")
+16 DO ERS410^PRC0G(PRCRI(410)_"^"_PRCH)
+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=2951000
+2 FOR
SET PRCB=$ORDER(^PRC(442,"AB",PRCB))
if 'PRCB
QUIT
Begin DoDot:1
+3 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
+4 WRITE !,$PIECE(PRCD,"^")
+5 IF $PIECE(PRCD,"^",12)]""
Begin DoDot:3
+6 NEW A,B
+7 SET A=0
FOR
SET A=$ORDER(^PRC(442,PRCRI(442),13,A))
if 'A
QUIT
SET B=$PIECE($GET(^(A,0)),"^")
IF B
DO ERS410^PRC0G(B_"^O")
WRITE " REQUEST-"_B
+8 QUIT
End DoDot:3
QUIT
+9 NEW PRCOBL,PRCOBD,PRCOBA
+10 NEW A,B,X,Y,Z
+11 WRITE " WITHOUT REQUEST"
+12 SET A=$PIECE(PRCD,"^")
SET PRC("SITE")=$PIECE(A,"-")
SET PRCOBL=$PIECE(A,"-",2)_"WR"
+13 IF $$DUP(PRC("SITE"),PRCOBL)
WRITE " *** DUPLICATE"
QUIT
+14 SET PRCOBD=$PIECE(^PRC(442,PRCRI(442),1),"^",15)
+15 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
+16 IF $PIECE($GET(^PRC(442,PRCRI(442),0)),"^",2)=25
SET PRCOBA=0
+17 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
+18 DO A410^PRC0F(.X,$PIECE(PRCD,"-")_"^"_$PIECE(PRCD,"^",3)_"^A^^"_PRCOBD_"^"_PRCOBA_"^"_PRCOBL)
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 DO EN^DDIOL("PURCHASE ORDERS WITHOUT REQUESTS DONE!")
+22 GOTO EXIT
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")_"-96-"
+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 DO EN^DDIOL("820 FMS TRANSACTION DONE!")
+16 DO EN^DDIOL("IFCAP PATCH *5*55 CONVERSION DONE!")
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
