- 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 Feb 18, 2025@23:46:07 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