PRCUFCF ;WISC/SJG-FMS MO2 SEGMENT ;11/29/93 09:45
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Routine is modification of PRCFFU2 for conversion processing
MO2(NODE,TYCODE) ;BUILD 'MO2' SEGMENT
; .1 - P.O. DATE FROM 442 .01 - NAME FROM 440
; 5 - VENDOR FROM 442 .06 - FEDERAL SOURCE FROM 440
; 6.4 - FOB POINT FROM 442 34 - FMS VENDOR CODE FROM 440
; 35 - ALT-ADDR-IND FROM 440
MO2A N SEG,FMSYR,FMSMO,FMSDAY,VEND,FMSVENCD,FMSVENNM,FMSPODAT,FMSFOB
S (FMSVENID,FMSVENCD,FMSVENNM,FMSFOB)=""
S TMPLINE=TMPLINE+1
K PRCTMP N DA S DIC=442,DR=".1;5;6.4",DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
MO2B I (TRCODE="MO")&(("^1^3^4^7^8^"[("^"_PRCFA("MP")_"^"))) D
.S (BEGDATE,FMSPODAT,PODATE)=$G(PRCTMP(442,+PO,.1,"I"))
.D DATE(FMSPODAT,.A,.B,.C) S FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
MO2C I (TRCODE="SO")&(PRCFA("MP")=2) D
.S (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
.D DATE(FMSPODAT,.A,.B,.C) S FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
MO2D I (TRCODE="SO")&(PRCFA("MP")=21) D
.I TYCODE="E" D
..D NOW^%DTC S (BEGDATE,FMSPODAT,PODATE)=$P(%,".")
..S FMSPODAT=$E(PODATE,2,3)_U_$E(PODATE,4,5)_U_$E(PODATE,6,7)
..Q
.I TYCODE="M" D
..S (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
..D DATE(FMSPODAT,.A,.B,.C) S FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
..Q
MO2E D
.I TYCODE="M" Q:'PRCFA("FOB")
.S (FMSFOB,FOB)=$G(PRCTMP(442,+PO,6.4,"I"))
.I FOB="" S (FMSFOB,FOB)="D"
MO2F D
.I TYCODE="M" Q:'PRCFA("VEND")
.S VEND=$G(PRCTMP(442,+PO,5,"I"))
.I VEND]"" D
..N DA S DIC=440,DR=".01;.06;34;35",DA=+VEND,DIQ="PRCTMP(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
..S FMSVENID=$G(PRCTMP(440,VEND,34,"E"))
..S FMSVENCD=$G(PRCTMP(440,VEND,35,"E"))
..S FMSVENNM=$G(PRCTMP(440,VEND,.01,"E"))
..S FMSVENNM=$E(FMSVENNM,1,30)
..I FMSVENID="" D
...S FMSFED=$G(PRCTMP(440,VEND,.06,"I"))
...S FMSVENID=$S(FMSFED:"MISCG",'FMSFED:"MISCN")
.I VEND="" I TRCODE="SO" S FMSVENID="MISCN",(FMSVENCD,FMSVENNM)=""
MO2G S SEG="MO2^"_FMSPODAT,$P(SEG,U,10)=TYCODE
I FMSVENID]"" S $P(SEG,U,14)=FMSVENID
I FMSVENCD]"" S $P(SEG,U,15)=FMSVENCD
I (FMSVENID="MISCN")!(FMSVENID="MISCG") I FMSVENNM]"" S $P(SEG,U,16)=FMSVENNM
I FMSFOB]"" S $P(SEG,U,24)=FMSFOB
S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~" K PRCTMP
Q
;
DATE(X,A,B,C) ;
S FMSYR=$E(X,2,3),FMSMO=$E(X,4,5),FMSDAY=$E(X,6,7)
Q
DATE1(X) ;
Q $E(X,4,5)_$E(X,6,7)_$E(X,2,3)
Q
ASKDATE(X) ;
N Y,ASKDATE
S %DT="AEX",%DT("A")=X D ^%DT
S ASKDATE=Y K %DT
Q ASKDATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUFCF 2547 printed Dec 13, 2024@02:19:44 Page 2
PRCUFCF ;WISC/SJG-FMS MO2 SEGMENT ;11/29/93 09:45
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ; Routine is modification of PRCFFU2 for conversion processing
MO2(NODE,TYCODE) ;BUILD 'MO2' SEGMENT
+1 ; .1 - P.O. DATE FROM 442 .01 - NAME FROM 440
+2 ; 5 - VENDOR FROM 442 .06 - FEDERAL SOURCE FROM 440
+3 ; 6.4 - FOB POINT FROM 442 34 - FMS VENDOR CODE FROM 440
+4 ; 35 - ALT-ADDR-IND FROM 440
MO2A NEW SEG,FMSYR,FMSMO,FMSDAY,VEND,FMSVENCD,FMSVENNM,FMSPODAT,FMSFOB
+1 SET (FMSVENID,FMSVENCD,FMSVENNM,FMSFOB)=""
+2 SET TMPLINE=TMPLINE+1
+3 KILL PRCTMP
NEW DA
SET DIC=442
SET DR=".1;5;6.4"
SET DA=+PO
SET DIQ="PRCTMP("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DIC,DIQ,DR
MO2B IF (TRCODE="MO")&(("^1^3^4^7^8^"[("^"_PRCFA("MP")_"^")))
Begin DoDot:1
+1 SET (BEGDATE,FMSPODAT,PODATE)=$GET(PRCTMP(442,+PO,.1,"I"))
+2 DO DATE(FMSPODAT,.A,.B,.C)
SET FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
End DoDot:1
MO2C IF (TRCODE="SO")&(PRCFA("MP")=2)
Begin DoDot:1
+1 SET (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
+2 DO DATE(FMSPODAT,.A,.B,.C)
SET FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
End DoDot:1
MO2D IF (TRCODE="SO")&(PRCFA("MP")=21)
Begin DoDot:1
+1 IF TYCODE="E"
Begin DoDot:2
+2 DO NOW^%DTC
SET (BEGDATE,FMSPODAT,PODATE)=$PIECE(%,".")
+3 SET FMSPODAT=$EXTRACT(PODATE,2,3)_U_$EXTRACT(PODATE,4,5)_U_$EXTRACT(PODATE,6,7)
+4 QUIT
End DoDot:2
+5 IF TYCODE="M"
Begin DoDot:2
+6 SET (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
+7 DO DATE(FMSPODAT,.A,.B,.C)
SET FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
+8 QUIT
End DoDot:2
End DoDot:1
MO2E Begin DoDot:1
+1 IF TYCODE="M"
if 'PRCFA("FOB")
QUIT
+2 SET (FMSFOB,FOB)=$GET(PRCTMP(442,+PO,6.4,"I"))
+3 IF FOB=""
SET (FMSFOB,FOB)="D"
End DoDot:1
MO2F Begin DoDot:1
+1 IF TYCODE="M"
if 'PRCFA("VEND")
QUIT
+2 SET VEND=$GET(PRCTMP(442,+PO,5,"I"))
+3 IF VEND]""
Begin DoDot:2
+4 NEW DA
SET DIC=440
SET DR=".01;.06;34;35"
SET DA=+VEND
SET DIQ="PRCTMP("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DIC,DIQ,DR
+5 SET FMSVENID=$GET(PRCTMP(440,VEND,34,"E"))
+6 SET FMSVENCD=$GET(PRCTMP(440,VEND,35,"E"))
+7 SET FMSVENNM=$GET(PRCTMP(440,VEND,.01,"E"))
+8 SET FMSVENNM=$EXTRACT(FMSVENNM,1,30)
+9 IF FMSVENID=""
Begin DoDot:3
+10 SET FMSFED=$GET(PRCTMP(440,VEND,.06,"I"))
+11 SET FMSVENID=$SELECT(FMSFED:"MISCG",'FMSFED:"MISCN")
End DoDot:3
End DoDot:2
+12 IF VEND=""
IF TRCODE="SO"
SET FMSVENID="MISCN"
SET (FMSVENCD,FMSVENNM)=""
End DoDot:1
MO2G SET SEG="MO2^"_FMSPODAT
SET $PIECE(SEG,U,10)=TYCODE
+1 IF FMSVENID]""
SET $PIECE(SEG,U,14)=FMSVENID
+2 IF FMSVENCD]""
SET $PIECE(SEG,U,15)=FMSVENCD
+3 IF (FMSVENID="MISCN")!(FMSVENID="MISCG")
IF FMSVENNM]""
SET $PIECE(SEG,U,16)=FMSVENNM
+4 IF FMSFOB]""
SET $PIECE(SEG,U,24)=FMSFOB
+5 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)=SEG_"^~"
KILL PRCTMP
+6 QUIT
+7 ;
DATE(X,A,B,C) ;
+1 SET FMSYR=$EXTRACT(X,2,3)
SET FMSMO=$EXTRACT(X,4,5)
SET FMSDAY=$EXTRACT(X,6,7)
+2 QUIT
DATE1(X) ;
+1 QUIT $EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)
+2 QUIT
ASKDATE(X) ;
+1 NEW Y,ASKDATE
+2 SET %DT="AEX"
SET %DT("A")=X
DO ^%DT
+3 SET ASKDATE=Y
KILL %DT
+4 QUIT ASKDATE
