- DII ;SFISC/GFT,XAK,TKW-OPTION RDR, INQUIRY ;5:21 AM 15 Mar 2005
- V ;;22.0;VA FileMan;**64,81,143**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- W !!,"VA FileMan "_$P($T(V),";",3),!
- ;
- ;If not Stand Alone make sure DUZ is defined ;22*143
- I '+$G(DUZ),$D(^VA(200,0))#2 D I '+$G(DUZ) W $C(7),!,$$EZBLD^DIALOG(7005),! Q
- . ;If ASKDUZ^XUP available, use it first
- . I $L($T(ASKDUZ^XUP)) N DIR,DIRUT,DUOUT,DTOUT D Q:($D(DUOUT)!$D(DTOUT))
- .. N XUEOFF,XUEON,DIDUZ
- .. I '$D(^%ZOSF("EOFF")) Q
- .. I '$D(^%ZOSF("EON")) Q
- .. W !,"Your Identity(DUZ) is 0(zero).",!,"Please identify yourself.",!
- .. S:$G(DUZ(0))]"" DIDUZ=DUZ(0)
- .. S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON")
- .. D ASKDUZ^XUP ;IA #4596
- .. S:$G(DIDUZ)]"" DUZ(0)=DIDUZ
- .. Q
- . ;If DUZ is still undefined as last resort call DIC
- . I '+$G(DUZ) D Q
- .. N DIC,DTOUT,DUOUT,DIDUZ
- .. S:$G(DUZ(0))]"" DIDUZ=DUZ(0)
- .. W $C(7),!,"Your Identity(DUZ) is still 0(zero).",!,"You need to identify yourself!",!
- .. S DUZ=0,DIC=200,DIC(0)="AEFNQZ",DIC("A")="New Person?: "
- .. ;Can't be POSTMASTER or SHARED MAIL and have an ACCESS CODE
- .. S DIC("S")="I ((+Y'<1)&($P(^(0),""^"",3)]""""))"
- .. D ^DIC
- .. I +Y'>1 Q
- .. S DUZ=+Y
- .. S DUZ(0)=$P(^VA(200,DUZ,0),U,4)
- .. S:$G(DIDUZ)]"" DUZ(0)=DIDUZ
- .. Q
- . Q
- ;
- NOKL D DT^DICRW,OS S DIK="^DOPT(""DII""," G F:$D(^DOPT("DII",9)) S ^(0)="OPTION^1.01^" F I=1:1 S X=$E($T(F+I),4,99) Q:X="" S ^DOPT("DII",I,0)=X
- D IXALL^DIK
- F S DIC=DIK,DIC(0)="AEQZ" D ^DIC K DIC,DIK G Q:Y<0 S X=$P(Y(0),U,2,99) K Y D @X W !!! D Q G NOKL
- ;;ENTER OR EDIT FILE ENTRIES^^DIB
- ;;PRINT FILE ENTRIES^^DIP
- ;;SEARCH FILE ENTRIES^^DIS
- ;;MODIFY FILE ATTRIBUTES^^DICATT
- ;;INQUIRE TO FILE ENTRIES^INQ^DII
- ;;UTILITY FUNCTIONS^^DIU
- ;;OTHER OPTIONS^^DII1
- ;;DATA DICTIONARY UTILITIES^^DDU
- ;;TRANSFER ENTRIES^^DIT
- ;
- Q D Q^DIB,Q^DICATT2,Q^DIARB
- K DRK,DIL,DIS,DK,DIACD,DIQ,DX,DQI,DISYS,DHIT,%X,%Y,%,DXS,Q,DIAR
- K A0,D9,DNP,DCC,DIJ,DP,DM,DQ,DICATT,DIFLD,D0,DIEL,DL,DC,DU,DIP
- K DH,DIYS,DINS,DIPT,DHD,DCL,DPP,DPQ,DALL,DIRUT,DIROUT,DUOUT,DTOUT
- Q
- INQ ;
- W !! D ^DICRW Q:'$D(DIC) S DI=DIC,DPP(1)=+Y_"^^^@",DK=+Y I $D(DICS) S DICSS=DICS
- B K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS S DIC=DI,DIC(0)="AEQM",DIK=0
- R D ^DIC I Y>0 S DIK=DIK+1,^UTILITY(U,$J,DIK,+Y)="",DIC("A")="ANOTHER ONE: " G R
- S G Q^DIP:'DIK!(X=U) G:DIK'>3 O
- D K DIRUT,DIROUT
- . N DIK,DI,DICSS,DX D S2^DIBT1 Q
- G:$D(DTOUT)!($D(DUOUT)) Q^DIP G:X="" O G:Y<0 S
- F X=1:1:DIK S ^DIBT(+Y,1,+$O(^UTILITY(U,$J,X,0)))=""
- S ^DIBT(+Y,"QR")=DT_U_DIK
- O K DIC G Q^DIP:$D(DTOUT) S DIC=DI,%=1
- W !,"STANDARD CAPTIONED OUTPUT" D YN^DICN G Q^DIP:%<0
- I '% W !?5,"Answer 'N' to create a formatted display as in the Print Option." G O
- I %=2 S L=1,Q="""",DPP=1,DPP(1,"IX")="^UTILITY(U,$J,"_DI_"^2" S:$D(DICSS) DICS=DICSS G N^DIP1
- D C G:$D(DIRUT) Q
- S IOP="HOME" D ^%ZIS I $D(DICSS) S DICS=DICSS
- DIQ N S S S=1 F DIK=1:1:DIK S DA=+$O(^UTILITY(U,$J,DIK,0)) W ! D:DIK>1 LF^DIQ Q:'S D CAPTION^DIQ(DK,DA,DIQ(0)) G:'S Q S S=S+2
- W !! Q:$D(DTOUT) G B
- ;
- P G Q^DI
- ;
- OS I $D(^%ZOSF("OS"))#2 S DISYS=+$P(^("OS"),"^",2) Q:DISYS>0
- S DISYS=$S($D(^DD("OS"))#2:^("OS"),1:100)
- Q
- AUD S DIACD=DIQ(0),DIQ(0)="C",DIQ=DA
- F DA=0:0 S DA=$O(^DIA(DK,"B",DIQ,DA)) Q:DA'>0 S DIC="^DIA("_DK_",",E="N<0",N=-1,DD=1.1,DIA=DK D GUY^DIQ Q:'S W !
- S DIQ(0)=DIACD Q
- ;
- C ;called from ^DIP21
- N DIR,I,L,Y,X,DITXT
- D BLD^DIALOG(7004,"","","DIR") S DITXT="" D S DITXT=DITXT_DIR
- . F I=1:1 Q:$G(DIR(I))="" S DITXT=DITXT_DIR(I)
- . Q
- K DIR S DIR(0)="SMB^"_DITXT,DIR("B")=$P($P(DITXT,":",2)," ",1),DIR("A")=$$EZBLD^DIALOG(8002)
- D ^DIR Q:$D(DIRUT)
- F I=1:1 S X=$P($P(DITXT,";",I),":") Q:X="" I X=Y S DIQ(0)=$S(I=2:"C",I=3:"R",I=4:"CR",1:"") Q
- I X'=Y S DIRUT=1 Q
- I $D(^DIA(DK)) S DIR(0)="Y",DIR("A")="DISPLAY AUDIT TRAIL",DIR("B")="No",DIR("?")="Answer 'Y' to display the audit trail for each Entry." D ^DIR Q:$D(DIRUT) S:Y=1 DIQ(0)=DIQ(0)_"A"
- Q
- ;7004 N:No;Y:Yes;R:Record Number;B:Both Computed and Number
- ;7005 You must have a valid DUZ! ;22*143
- ;8002 Include COMPUTED fields
- DII ;SFISC/GFT,XAK,TKW-OPTION RDR, INQUIRY ;5:21 AM 15 Mar 2005
- V ;;22.0;VA FileMan;**64,81,143**;Mar 30, 1999
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 WRITE !!,"VA FileMan "_$PIECE($TEXT(V),";",3),!
- +4 ;
- +5 ;If not Stand Alone make sure DUZ is defined ;22*143
- +6 IF '+$GET(DUZ)
- IF $DATA(^VA(200,0))#2
- Begin DoDot:1
- +7 ;If ASKDUZ^XUP available, use it first
- +8 IF $LENGTH($TEXT(ASKDUZ^XUP))
- NEW DIR,DIRUT,DUOUT,DTOUT
- Begin DoDot:2
- +9 NEW XUEOFF,XUEON,DIDUZ
- +10 IF '$DATA(^%ZOSF("EOFF"))
- QUIT
- +11 IF '$DATA(^%ZOSF("EON"))
- QUIT
- +12 WRITE !,"Your Identity(DUZ) is 0(zero).",!,"Please identify yourself.",!
- +13 IF $GET(DUZ(0))]""
- SET DIDUZ=DUZ(0)
- +14 SET XUEOFF=^%ZOSF("EOFF")
- SET XUEON=^%ZOSF("EON")
- +15 ;IA #4596
- DO ASKDUZ^XUP
- +16 IF $GET(DIDUZ)]""
- SET DUZ(0)=DIDUZ
- +17 QUIT
- End DoDot:2
- IF ($DATA(DUOUT)!$DATA(DTOUT))
- QUIT
- +18 ;If DUZ is still undefined as last resort call DIC
- +19 IF '+$GET(DUZ)
- Begin DoDot:2
- +20 NEW DIC,DTOUT,DUOUT,DIDUZ
- +21 IF $GET(DUZ(0))]""
- SET DIDUZ=DUZ(0)
- +22 WRITE $CHAR(7),!,"Your Identity(DUZ) is still 0(zero).",!,"You need to identify yourself!",!
- +23 SET DUZ=0
- SET DIC=200
- SET DIC(0)="AEFNQZ"
- SET DIC("A")="New Person?: "
- +24 ;Can't be POSTMASTER or SHARED MAIL and have an ACCESS CODE
- +25 SET DIC("S")="I ((+Y'<1)&($P(^(0),""^"",3)]""""))"
- +26 DO ^DIC
- +27 IF +Y'>1
- QUIT
- +28 SET DUZ=+Y
- +29 SET DUZ(0)=$PIECE(^VA(200,DUZ,0),U,4)
- +30 IF $GET(DIDUZ)]""
- SET DUZ(0)=DIDUZ
- +31 QUIT
- End DoDot:2
- QUIT
- +32 QUIT
- End DoDot:1
- IF '+$GET(DUZ)
- WRITE $CHAR(7),!,$$EZBLD^DIALOG(7005),!
- QUIT
- +33 ;
- NOKL DO DT^DICRW
- DO OS
- SET DIK="^DOPT(""DII"","
- IF $DATA(^DOPT("DII",9))
- GOTO F
- SET ^(0)="OPTION^1.01^"
- FOR I=1:1
- SET X=$EXTRACT($TEXT(F+I),4,99)
- IF X=""
- QUIT
- SET ^DOPT("DII",I,0)=X
- +1 DO IXALL^DIK
- F SET DIC=DIK
- SET DIC(0)="AEQZ"
- DO ^DIC
- KILL DIC,DIK
- IF Y<0
- GOTO Q
- SET X=$PIECE(Y(0),U,2,99)
- KILL Y
- DO @X
- WRITE !!!
- DO Q
- GOTO NOKL
- +1 ;;ENTER OR EDIT FILE ENTRIES^^DIB
- +2 ;;PRINT FILE ENTRIES^^DIP
- +3 ;;SEARCH FILE ENTRIES^^DIS
- +4 ;;MODIFY FILE ATTRIBUTES^^DICATT
- +5 ;;INQUIRE TO FILE ENTRIES^INQ^DII
- +6 ;;UTILITY FUNCTIONS^^DIU
- +7 ;;OTHER OPTIONS^^DII1
- +8 ;;DATA DICTIONARY UTILITIES^^DDU
- +9 ;;TRANSFER ENTRIES^^DIT
- +10 ;
- Q DO Q^DIB
- DO Q^DICATT2
- DO Q^DIARB
- +1 KILL DRK,DIL,DIS,DK,DIACD,DIQ,DX,DQI,DISYS,DHIT,%X,%Y,%,DXS,Q,DIAR
- +2 KILL A0,D9,DNP,DCC,DIJ,DP,DM,DQ,DICATT,DIFLD,D0,DIEL,DL,DC,DU,DIP
- +3 KILL DH,DIYS,DINS,DIPT,DHD,DCL,DPP,DPQ,DALL,DIRUT,DIROUT,DUOUT,DTOUT
- +4 QUIT
- INQ ;
- +1 WRITE !!
- DO ^DICRW
- IF '$DATA(DIC)
- QUIT
- SET DI=DIC
- SET DPP(1)=+Y_"^^^@"
- SET DK=+Y
- IF $DATA(DICS)
- SET DICSS=DICS
- B KILL ^UTILITY($JOB),^(U,$JOB),DIC,DIQ,DISV,DIBT,DICS
- SET DIC=DI
- SET DIC(0)="AEQM"
- SET DIK=0
- R DO ^DIC
- IF Y>0
- SET DIK=DIK+1
- SET ^UTILITY(U,$JOB,DIK,+Y)=""
- SET DIC("A")="ANOTHER ONE: "
- GOTO R
- S IF 'DIK!(X=U)
- GOTO Q^DIP
- IF DIK'>3
- GOTO O
- +1 Begin DoDot:1
- +2 NEW DIK,DI,DICSS,DX
- DO S2^DIBT1
- QUIT
- End DoDot:1
- KILL DIRUT,DIROUT
- +3 IF $DATA(DTOUT)!($DATA(DUOUT))
- GOTO Q^DIP
- IF X=""
- GOTO O
- IF Y<0
- GOTO S
- +4 FOR X=1:1:DIK
- SET ^DIBT(+Y,1,+$ORDER(^UTILITY(U,$JOB,X,0)))=""
- +5 SET ^DIBT(+Y,"QR")=DT_U_DIK
- O KILL DIC
- IF $DATA(DTOUT)
- GOTO Q^DIP
- SET DIC=DI
- SET %=1
- +1 WRITE !,"STANDARD CAPTIONED OUTPUT"
- DO YN^DICN
- IF %<0
- GOTO Q^DIP
- +2 IF '%
- WRITE !?5,"Answer 'N' to create a formatted display as in the Print Option."
- GOTO O
- +3 IF %=2
- SET L=1
- SET Q=""""
- SET DPP=1
- SET DPP(1,"IX")="^UTILITY(U,$J,"_DI_"^2"
- IF $DATA(DICSS)
- SET DICS=DICSS
- GOTO N^DIP1
- +4 DO C
- IF $DATA(DIRUT)
- GOTO Q
- +5 SET IOP="HOME"
- DO ^%ZIS
- IF $DATA(DICSS)
- SET DICS=DICSS
- DIQ NEW S
- SET S=1
- FOR DIK=1:1:DIK
- SET DA=+$ORDER(^UTILITY(U,$JOB,DIK,0))
- WRITE !
- IF DIK>1
- DO LF^DIQ
- IF 'S
- QUIT
- DO CAPTION^DIQ(DK,DA,DIQ(0))
- IF 'S
- GOTO Q
- SET S=S+2
- +1 WRITE !!
- IF $DATA(DTOUT)
- QUIT
- GOTO B
- +2 ;
- P GOTO Q^DI
- +1 ;
- OS IF $DATA(^%ZOSF("OS"))#2
- SET DISYS=+$PIECE(^("OS"),"^",2)
- IF DISYS>0
- QUIT
- +1 SET DISYS=$SELECT($DATA(^DD("OS"))#2:^("OS"),1:100)
- +2 QUIT
- AUD SET DIACD=DIQ(0)
- SET DIQ(0)="C"
- SET DIQ=DA
- +1 FOR DA=0:0
- SET DA=$ORDER(^DIA(DK,"B",DIQ,DA))
- IF DA'>0
- QUIT
- SET DIC="^DIA("_DK_","
- SET E="N<0"
- SET N=-1
- SET DD=1.1
- SET DIA=DK
- DO GUY^DIQ
- IF 'S
- QUIT
- WRITE !
- +2 SET DIQ(0)=DIACD
- QUIT
- +3 ;
- C ;called from ^DIP21
- +1 NEW DIR,I,L,Y,X,DITXT
- +2 DO BLD^DIALOG(7004,"","","DIR")
- SET DITXT=""
- Begin DoDot:1
- +3 FOR I=1:1
- IF $GET(DIR(I))=""
- QUIT
- SET DITXT=DITXT_DIR(I)
- +4 QUIT
- End DoDot:1
- SET DITXT=DITXT_DIR
- +5 KILL DIR
- SET DIR(0)="SMB^"_DITXT
- SET DIR("B")=$PIECE($PIECE(DITXT,":",2)," ",1)
- SET DIR("A")=$$EZBLD^DIALOG(8002)
- +6 DO ^DIR
- IF $DATA(DIRUT)
- QUIT
- +7 FOR I=1:1
- SET X=$PIECE($PIECE(DITXT,";",I),":")
- IF X=""
- QUIT
- IF X=Y
- SET DIQ(0)=$SELECT(I=2:"C",I=3:"R",I=4:"CR",1:"")
- QUIT
- +8 IF X'=Y
- SET DIRUT=1
- QUIT
- +9 IF $DATA(^DIA(DK))
- SET DIR(0)="Y"
- SET DIR("A")="DISPLAY AUDIT TRAIL"
- SET DIR("B")="No"
- SET DIR("?")="Answer 'Y' to display the audit trail for each Entry."
- DO ^DIR
- IF $DATA(DIRUT)
- QUIT
- IF Y=1
- SET DIQ(0)=DIQ(0)_"A"
- +10 QUIT
- +11 ;7004 N:No;Y:Yes;R:Record Number;B:Both Computed and Number
- +12 ;7005 You must have a valid DUZ! ;22*143
- +13 ;8002 Include COMPUTED fields
