ENFAR9 ;WIRMFO/SAB-FAP DOCUMENT HISTORY OF EQUIPMENT ;7.21.97
;;7.0;ENGINEERING;**29,39**;AUG 17, 1993
;
EN ; entry
; ask equipment
D GETEQ^ENUTL G:Y'>0 EXIT
S ENDA("EQ")=+Y
; ask detailed
S DIR(0)="Y",DIR("A")="Include transaction details",DIR("B")="YES"
D ^DIR K DIR G:$D(DIRUT) EXIT
S ENDETAIL=+Y
; ask device
S %ZIS="QM" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EN
. S ZTRTN="QEN^ENFAR9",ZTDESC="FAP Document History of Equipment"
. S ZTSAVE("ENDA(""EQ"")")="",ZTSAVE("ENDETAIL")=""
. D ^%ZTLOAD,HOME^%ZIS K ZTSK
QEN ; queued entry
U IO
; find FAP documents
K ENDOC
S ENVALFA=0,ENVALFB=0
S (END,ENPG)=0 D NOW^%DTC S Y=% D DD^%DT S ENDTR=Y
D HD
F ENFILE=6915.2:.1:6915.6 D
. S ENDA("F?")=0
. F S ENDA("F?")=$O(^ENG(ENFILE,"B",ENDA("EQ"),ENDA("F?"))) Q:'ENDA("F?") D
. . S ENDT=$$GET1^DIQ(ENFILE,ENDA("F?"),1,"I")
. . S:ENDT ENDOC(ENDT,ENFILE,ENDA("F?"))=""
I '$D(ENDOC) W !!," NO FAP DOCUMENTS FOUND"
I $D(ENDOC) D
. ; load FA Type -> SGL table
. K ENFATT S I=0 F S I=$O(^ENG(6914.3,I)) Q:'I S X=^(I,0) I $P(X,U)]"",$P(X,U,3)]"" S ENFATT($P(X,U,3))=$P(X,U)
. I ENDETAIL D ; for calls to ENFARC2
. . S ENTAG("HD")="HD^ENFAR9"
. . S ENTAG("HDC")="HDC^ENFAR9"
. . S ENTAG("FT")="FT^ENFAR9"
. ; print data
. S ENDT="" F S ENDT=$O(ENDOC(ENDT)) Q:ENDT="" D Q:END
. . S ENFILE="" F S ENFILE=$O(ENDOC(ENDT,ENFILE)) Q:ENFILE="" D Q:END
. . . S ENDA("F?")=$O(ENDOC(ENDT,ENFILE,0))
. . . D @("DOC"_$P(ENFILE,".",2))
. . . I 'ENDETAIL,$Y+6>IOSL D FT,HD Q:END
. . . I ENDETAIL,$Y+11>IOSL D FT,HD Q:END
. . . W !,ENTRC,?6,ENTRN,?16,$TR($$FMTE^XLFDT(ENDT,"2DF")," ",0),?26,ENSN
. . . W:ENFAT]"" ?33,$G(ENFATT(ENFAT))
. . . W:ENVAL]"" ?38,$J("$"_$FN(ENVAL,",",2),14)
. . . W ?54,$E($P($$GET1^DIQ(ENFILE,ENDA("F?"),1.5),","),1,10)
. . . W ?65,$J("$"_$FN(ENVALFA+ENVALFB,",",2),14)
. . . I ENDETAIL W:ENFILE'[".6" ! D @("F"_$P(ENFILE,".",2)_"^ENFARC2") W !
I 'END D FT
D ^%ZISC
I $E(IOST,1,2)="C-" W ! G EN
EXIT I $D(ZTQUEUED) S ZTREQ="@"
K END,ENDA,ENDETAIL,ENDOC,ENDT,ENDTR,ENFAT,ENFATT,ENFILE
K ENPG,ENSN,ENTAG,ENTRC,ENTRN,ENVAL,ENVALFA,ENVALFB,I,X,Y
Q
HD ; header
I $E(IOST,1,2)="C-",ENPG S DIR(0)="E" D ^DIR K DIR I 'Y S END=1 Q
I $E(IOST,1,2)="C-"!ENPG W @IOF S $X=0
S ENPG=ENPG+1
W "FAP DOCUMENT HISTORY FOR EQUIPMENT",?49,ENDTR,?72,"page ",ENPG
W !," ENTRY #: ",ENDA("EQ")
W " CURRENT VALUE: $",$FN($$GET1^DIQ(6914,ENDA("EQ"),12),",",2)
W !!,"TRANSACTION",?26,"STA",?33,"SGL",?38,"DOCUMENT VALUE",?54,"SENDER",?65,"ASSET VALUE"
W !,"CODE*",?6,"NUMBER",?16,"DATE",?26,"NBR",?65,"AFTER DOCUMENT"
W !,"-----",?6,"---------",?16,"--------",?26,"-----",?33,"----"
W ?38,"--------------",?54,"----------",?65,"--------------"
Q
HDC ; header for continued transaction
W !,?5,"Transaction: ",$E(ENTRC,1,2),"-",ENTRN," (continued)"
Q
FT ; footer
W !!," * Betterment # follows FB and FC. T (Turn-In) or D (Final Disp.) follows FD."
Q
DOC2 ; FA document
S ENTRC="FA 00"
S ENTRN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
S ENSN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),24),1,5)
S ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),25)
S ENVAL=$$GET1^DIQ(ENFILE,ENDA("F?"),53)
S ENVALFA=ENVAL,ENVALFB=0
S ENDA("FA")=ENDA("F?")
Q
DOC3 ; FB document
S ENTRC="FB "_$$GET1^DIQ(ENFILE,ENDA("F?"),23)
S ENTRN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
S ENSN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),21),1,5)
S ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),22)
S ENVAL=$$GET1^DIQ(ENFILE,ENDA("F?"),36)
S ENVALFB=ENVALFB+ENVAL
Q
DOC4 ; FC document
S ENTRC="FC "_$$GET1^DIQ(ENFILE,ENDA("F?"),27)
S ENTRN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
S ENSN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),25),1,5)
S ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),26)
S ENVAL=$$GET1^DIQ(ENFILE,ENDA("F?"),54)
I ENTRC["00",ENVAL]"" S ENVALFA=ENVAL
I ENTRC'["00",ENVAL]"" S ENVALFB=ENVALFB+(ENVAL-$$GET1^DIQ(ENFILE,ENDA("F?"),103))
Q
DOC5 ; FD document
S ENTRC="FD "_$$GET1^DIQ(ENFILE,ENDA("F?"),100,"I")
S ENTRN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
S ENSN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),27),1,5)
S ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),28)
S ENVAL=""
Q
DOC6 ; FR document
S ENTRC="FR"
S ENTRN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
S ENSN=$E($$GET1^DIQ(ENFILE,ENDA("F?"),24),1,5)
S ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),25)
S ENVAL=""
Q
;ENFAR9
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENFAR9 4367 printed Nov 22, 2024@17:03:50 Page 2
ENFAR9 ;WIRMFO/SAB-FAP DOCUMENT HISTORY OF EQUIPMENT ;7.21.97
+1 ;;7.0;ENGINEERING;**29,39**;AUG 17, 1993
+2 ;
EN ; entry
+1 ; ask equipment
+2 DO GETEQ^ENUTL
if Y'>0
GOTO EXIT
+3 SET ENDA("EQ")=+Y
+4 ; ask detailed
+5 SET DIR(0)="Y"
SET DIR("A")="Include transaction details"
SET DIR("B")="YES"
+6 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+7 SET ENDETAIL=+Y
+8 ; ask device
+9 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTRTN="QEN^ENFAR9"
SET ZTDESC="FAP Document History of Equipment"
+12 SET ZTSAVE("ENDA(""EQ"")")=""
SET ZTSAVE("ENDETAIL")=""
+13 DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO EN
QEN ; queued entry
+1 USE IO
+2 ; find FAP documents
+3 KILL ENDOC
+4 SET ENVALFA=0
SET ENVALFB=0
+5 SET (END,ENPG)=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET ENDTR=Y
+6 DO HD
+7 FOR ENFILE=6915.2:.1:6915.6
Begin DoDot:1
+8 SET ENDA("F?")=0
+9 FOR
SET ENDA("F?")=$ORDER(^ENG(ENFILE,"B",ENDA("EQ"),ENDA("F?")))
if 'ENDA("F?")
QUIT
Begin DoDot:2
+10 SET ENDT=$$GET1^DIQ(ENFILE,ENDA("F?"),1,"I")
+11 if ENDT
SET ENDOC(ENDT,ENFILE,ENDA("F?"))=""
End DoDot:2
End DoDot:1
+12 IF '$DATA(ENDOC)
WRITE !!," NO FAP DOCUMENTS FOUND"
+13 IF $DATA(ENDOC)
Begin DoDot:1
+14 ; load FA Type -> SGL table
+15 KILL ENFATT
SET I=0
FOR
SET I=$ORDER(^ENG(6914.3,I))
if 'I
QUIT
SET X=^(I,0)
IF $PIECE(X,U)]""
IF $PIECE(X,U,3)]""
SET ENFATT($PIECE(X,U,3))=$PIECE(X,U)
+16 ; for calls to ENFARC2
IF ENDETAIL
Begin DoDot:2
+17 SET ENTAG("HD")="HD^ENFAR9"
+18 SET ENTAG("HDC")="HDC^ENFAR9"
+19 SET ENTAG("FT")="FT^ENFAR9"
End DoDot:2
+20 ; print data
+21 SET ENDT=""
FOR
SET ENDT=$ORDER(ENDOC(ENDT))
if ENDT=""
QUIT
Begin DoDot:2
+22 SET ENFILE=""
FOR
SET ENFILE=$ORDER(ENDOC(ENDT,ENFILE))
if ENFILE=""
QUIT
Begin DoDot:3
+23 SET ENDA("F?")=$ORDER(ENDOC(ENDT,ENFILE,0))
+24 DO @("DOC"_$PIECE(ENFILE,".",2))
+25 IF 'ENDETAIL
IF $Y+6>IOSL
DO FT
DO HD
if END
QUIT
+26 IF ENDETAIL
IF $Y+11>IOSL
DO FT
DO HD
if END
QUIT
+27 WRITE !,ENTRC,?6,ENTRN,?16,$TRANSLATE($$FMTE^XLFDT(ENDT,"2DF")," ",0),?26,ENSN
+28 if ENFAT]""
WRITE ?33,$GET(ENFATT(ENFAT))
+29 if ENVAL]""
WRITE ?38,$JUSTIFY("$"_$FNUMBER(ENVAL,",",2),14)
+30 WRITE ?54,$EXTRACT($PIECE($$GET1^DIQ(ENFILE,ENDA("F?"),1.5),","),1,10)
+31 WRITE ?65,$JUSTIFY("$"_$FNUMBER(ENVALFA+ENVALFB,",",2),14)
+32 IF ENDETAIL
if ENFILE'[".6"
WRITE !
DO @("F"_$PIECE(ENFILE,".",2)_"^ENFARC2")
WRITE !
End DoDot:3
if END
QUIT
End DoDot:2
if END
QUIT
End DoDot:1
+33 IF 'END
DO FT
+34 DO ^%ZISC
+35 IF $EXTRACT(IOST,1,2)="C-"
WRITE !
GOTO EN
EXIT IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 KILL END,ENDA,ENDETAIL,ENDOC,ENDT,ENDTR,ENFAT,ENFATT,ENFILE
+2 KILL ENPG,ENSN,ENTAG,ENTRC,ENTRN,ENVAL,ENVALFA,ENVALFB,I,X,Y
+3 QUIT
HD ; header
+1 IF $EXTRACT(IOST,1,2)="C-"
IF ENPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET END=1
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"!ENPG
WRITE @IOF
SET $X=0
+3 SET ENPG=ENPG+1
+4 WRITE "FAP DOCUMENT HISTORY FOR EQUIPMENT",?49,ENDTR,?72,"page ",ENPG
+5 WRITE !," ENTRY #: ",ENDA("EQ")
+6 WRITE " CURRENT VALUE: $",$FNUMBER($$GET1^DIQ(6914,ENDA("EQ"),12),",",2)
+7 WRITE !!,"TRANSACTION",?26,"STA",?33,"SGL",?38,"DOCUMENT VALUE",?54,"SENDER",?65,"ASSET VALUE"
+8 WRITE !,"CODE*",?6,"NUMBER",?16,"DATE",?26,"NBR",?65,"AFTER DOCUMENT"
+9 WRITE !,"-----",?6,"---------",?16,"--------",?26,"-----",?33,"----"
+10 WRITE ?38,"--------------",?54,"----------",?65,"--------------"
+11 QUIT
HDC ; header for continued transaction
+1 WRITE !,?5,"Transaction: ",$EXTRACT(ENTRC,1,2),"-",ENTRN," (continued)"
+2 QUIT
FT ; footer
+1 WRITE !!," * Betterment # follows FB and FC. T (Turn-In) or D (Final Disp.) follows FD."
+2 QUIT
DOC2 ; FA document
+1 SET ENTRC="FA 00"
+2 SET ENTRN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
+3 SET ENSN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),24),1,5)
+4 SET ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),25)
+5 SET ENVAL=$$GET1^DIQ(ENFILE,ENDA("F?"),53)
+6 SET ENVALFA=ENVAL
SET ENVALFB=0
+7 SET ENDA("FA")=ENDA("F?")
+8 QUIT
DOC3 ; FB document
+1 SET ENTRC="FB "_$$GET1^DIQ(ENFILE,ENDA("F?"),23)
+2 SET ENTRN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
+3 SET ENSN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),21),1,5)
+4 SET ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),22)
+5 SET ENVAL=$$GET1^DIQ(ENFILE,ENDA("F?"),36)
+6 SET ENVALFB=ENVALFB+ENVAL
+7 QUIT
DOC4 ; FC document
+1 SET ENTRC="FC "_$$GET1^DIQ(ENFILE,ENDA("F?"),27)
+2 SET ENTRN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
+3 SET ENSN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),25),1,5)
+4 SET ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),26)
+5 SET ENVAL=$$GET1^DIQ(ENFILE,ENDA("F?"),54)
+6 IF ENTRC["00"
IF ENVAL]""
SET ENVALFA=ENVAL
+7 IF ENTRC'["00"
IF ENVAL]""
SET ENVALFB=ENVALFB+(ENVAL-$$GET1^DIQ(ENFILE,ENDA("F?"),103))
+8 QUIT
DOC5 ; FD document
+1 SET ENTRC="FD "_$$GET1^DIQ(ENFILE,ENDA("F?"),100,"I")
+2 SET ENTRN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
+3 SET ENSN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),27),1,5)
+4 SET ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),28)
+5 SET ENVAL=""
+6 QUIT
DOC6 ; FR document
+1 SET ENTRC="FR"
+2 SET ENTRN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),10),1,9)
+3 SET ENSN=$EXTRACT($$GET1^DIQ(ENFILE,ENDA("F?"),24),1,5)
+4 SET ENFAT=$$GET1^DIQ(ENFILE,ENDA("F?"),25)
+5 SET ENVAL=""
+6 QUIT
+7 ;ENFAR9
