- DIS0 ;SFISC/GFT-SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;30JAN2005
- ;;22.0;VA FileMan;**144**;Mar 30, 1999;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- W ! K R,N,DL,DE,DJ
- S O=0,E=$D(DC(2)),N="IF: A// ",DE=$S(E:"IF: ",1:N),DL=0
- S C=","
- R W !,DE K DV R X:DTIME S:'$T DTOUT=1 G Q:X[U!'$T
- I X="" S DV=1,DU=X G 1:DL S DQ="TYPE '^' TO EXIT",Y="^1^",DL=1 G BAD:E D ASKQ G L
- S Y=U,P=0,DU="",D="",DL=DL+1
- P S P=P+1,DQ=$E(X,P) I DQ="" G BAD:Y=U,L
- I DQ?.A S DV=$A(DQ)-64 I $D(DC(DV)) D ASKQ G CHK
- G P:"&+ "[DQ I DU="","'-"[DQ S DU="'" G P
- BAD D W !! K DJ(DL),DE(DL) S DL=DL-1 G R
- .I DQ?."?" D BLD^DIALOG($S($D(DC(2)):8004.2,1:8004.1)),MSG^DIALOG("WH") Q ;HELP depending on whether there is a CONDITION B
- .W " <",DQ,">??"
- ;
- ASKQ S J=DC(DV),%=J["?."" """,I=J["^'"+(DU["'")#2 I J["W^" S DV(DV)=$S(I:2-%,1:%+%+1) S:% DC(DV)=$E(J,1,$L(J)-5)_"=""""" Q
- S:$P(J,U)[C DV(DV)=J?.E1",.01^".E&%+(I+%#2) Q
- ;
- CHK S %=$F(Y,U_DV) I % S %=$P($E(Y,%),U,1)'=DU,DQ=""""_DQ_""" AND """_$E("'",%)_DQ_""" IS "_$P("REDUNDANT^CONTRADICTORY",U,%+1) G BAD
- S %=1,Y=Y_DV_DU_U,DU="",J=$P(DC(DV),U,1) G P:J'[C F Z=2:1 I $P(J,C,Z,99)'[C S J=$P(J,C,1,Z-1)_C Q
- I J=D D SAMEQ S:%=1 DJ(DL,DV)=DX(DV)
- S D=J,DJ=DV G P:%>0
- Q G Q^DIS2
- ;
- SAMEQ I J<0,$P(DY(-J),U,3)="" Q
- W !?8,"CONDITION -"_$C(DV+64)_"- WILL APPLY TO THE SAME MULTIPLE AS CONDITION -"_$C(DJ+64)_"-",!?8,"...OK" G YN^DICN
- ;
- L S P=O,DL(DL)=Y,DE="OR: " F %=2:1 S X=$P(Y,U,%) Q:X="" S O=O+1,^UTILITY($J,O,0)=$S(%>2:$S($D(DJ(DL,+X)):" together with ",1:" and "),O=1:"",1:" Or ")_$P("not ",U,X["'")_O(+X)
- W:$X>18 ! W " " F %=P+1:1 Q:'$D(^UTILITY($J,%,0)) S X=^(0) W:$L(X)+$X>77 !?13 W " "_$P(X,U) I $P(X,U,2)'="" W " ("_$P(X,U,2)_")"
- S DV=0
- DV S DV=$O(DV(DV)) S:DV="" DV=-1 G:DV'>0 R:E,1 G DV:$D(DJ(DL,DV)) S I=$P(DC(DV),U,1),D=DK,DN=0,Y="DO YOU WANT THIS SEARCH SPECIFICATION TO BE CONSIDERED TRUE FOR CONDITION -"_$C(DV+64)_"-"
- G S DN=DN+1,P=$P(I,C,1),I=$P(I,C,2,99) G W:P["W",DV:I="" I P<0 S J=DY(-P),D=+J,R=" '"_$P(^DIC(D,0),U,1)_"' ENTRIES " G G:'$P(J,U,3)
- E S D=+$P(^DD(D,P,0),U,2),R=" '"_$O(^DD(D,0,"NM",0))_"' MULTIPLES "
- HOW W !!,Y,!?8,"1) WHEN AT LEAST ONE OF THE"_R_"SATISFIES IT"
- W !?8,"2) WHEN ALL OF THE"_R_"SATISFY IT" S X=2
- I DV(DV) W !?8,"3) WHEN ALL OF THE"_R_"SATISFY IT,",!?16,"OR WHEN THERE ARE NO"_R S X=3
- W !?4,"CHOOSE 1-"_X_": " I DV(DV)>1 W 3 S %1=3
- E W 1 S %1=1
- R "// ",%:DTIME,! S:'$T DTOUT=1 S:%="" %=%1 K %1 G Q:%=U!'$T,HOW:%>X!'% I %>1 S DE(DL,DV,DN)=%,O=O+1,^UTILITY($J,O,0)=" for all"_R_$P(", or when no"_R_"exist",U,%>2)
- G G
- ;
- W I DV(DV)-2 S DE(DL,DV,DN)=DV(DV) G DV
- W !!,Y,!?7,"WHEN THERE IS NO '"_$P(^DD(D,+P,0),U,1)_"' TEXT AT ALL"
- S %=1 D YN^DICN G Q:%<0,W:'% S DE(DL,DV,DN)=4-% G DV
- ;
- 1 K O,DX,Y G ^DIS1
- DIS0 ;SFISC/GFT-SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;30JAN2005
- +1 ;;22.0;VA FileMan;**144**;Mar 30, 1999;Build 5
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 WRITE !
- KILL R,N,DL,DE,DJ
- +4 SET O=0
- SET E=$DATA(DC(2))
- SET N="IF: A// "
- SET DE=$SELECT(E:"IF: ",1:N)
- SET DL=0
- +5 SET C=","
- R WRITE !,DE
- KILL DV
- READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- IF X[U!'$TEST
- GOTO Q
- +1 IF X=""
- SET DV=1
- SET DU=X
- IF DL
- GOTO 1
- SET DQ="TYPE '^' TO EXIT"
- SET Y="^1^"
- SET DL=1
- IF E
- GOTO BAD
- DO ASKQ
- GOTO L
- +2 SET Y=U
- SET P=0
- SET DU=""
- SET D=""
- SET DL=DL+1
- P SET P=P+1
- SET DQ=$EXTRACT(X,P)
- IF DQ=""
- IF Y=U
- GOTO BAD
- GOTO L
- +1 IF DQ?.A
- SET DV=$ASCII(DQ)-64
- IF $DATA(DC(DV))
- DO ASKQ
- GOTO CHK
- +2 IF "&+ "[DQ
- GOTO P
- IF DU=""
- IF "'-"[DQ
- SET DU="'"
- GOTO P
- BAD Begin DoDot:1
- +1 ;HELP depending on whether there is a CONDITION B
- IF DQ?."?"
- DO BLD^DIALOG($SELECT($DATA(DC(2)):8004.2,1:8004.1))
- DO MSG^DIALOG("WH")
- QUIT
- +2 WRITE " <",DQ,">??"
- End DoDot:1
- WRITE !!
- KILL DJ(DL),DE(DL)
- SET DL=DL-1
- GOTO R
- +3 ;
- ASKQ SET J=DC(DV)
- SET %=J["?."" """
- SET I=J["^'"+(DU["'")#2
- IF J["W^"
- SET DV(DV)=$SELECT(I:2-%,1:%+%+1)
- IF %
- SET DC(DV)=$EXTRACT(J,1,$LENGTH(J)-5)_"="""""
- QUIT
- +1 IF $PIECE(J,U)[C
- SET DV(DV)=J?.E1",.01^".E&%+(I+%#2)
- QUIT
- +2 ;
- CHK SET %=$FIND(Y,U_DV)
- IF %
- SET %=$PIECE($EXTRACT(Y,%),U,1)'=DU
- SET DQ=""""_DQ_""" AND """_$EXTRACT("'",%)_DQ_""" IS "_$PIECE("REDUNDANT^CONTRADICTORY",U,%+1)
- GOTO BAD
- +1 SET %=1
- SET Y=Y_DV_DU_U
- SET DU=""
- SET J=$PIECE(DC(DV),U,1)
- IF J'[C
- GOTO P
- FOR Z=2:1
- IF $PIECE(J,C,Z,99)'[C
- SET J=$PIECE(J,C,1,Z-1)_C
- QUIT
- +2 IF J=D
- DO SAMEQ
- IF %=1
- SET DJ(DL,DV)=DX(DV)
- +3 SET D=J
- SET DJ=DV
- IF %>0
- GOTO P
- Q GOTO Q^DIS2
- +1 ;
- SAMEQ IF J<0
- IF $PIECE(DY(-J),U,3)=""
- QUIT
- +1 WRITE !?8,"CONDITION -"_$CHAR(DV+64)_"- WILL APPLY TO THE SAME MULTIPLE AS CONDITION -"_$CHAR(DJ+64)_"-",!?8,"...OK"
- GOTO YN^DICN
- +2 ;
- L SET P=O
- SET DL(DL)=Y
- SET DE="OR: "
- FOR %=2:1
- SET X=$PIECE(Y,U,%)
- IF X=""
- QUIT
- SET O=O+1
- SET ^UTILITY($JOB,O,0)=$SELECT(%>2:$SELECT($DATA(DJ(DL,+X)):" together with ",1:" and "),O=1:"",1:" Or ")_$PIECE("not ",U,X["'")_O(+X)
- +1 IF $X>18
- WRITE !
- WRITE " "
- FOR %=P+1:1
- IF '$DATA(^UTILITY($JOB,%,0))
- QUIT
- SET X=^(0)
- IF $LENGTH(X)+$X>77
- WRITE !?13
- WRITE " "_$PIECE(X,U)
- IF $PIECE(X,U,2)'=""
- WRITE " ("_$PIECE(X,U,2)_")"
- +2 SET DV=0
- DV SET DV=$ORDER(DV(DV))
- IF DV=""
- SET DV=-1
- IF DV'>0
- IF E
- GOTO R
- GOTO 1
- IF $DATA(DJ(DL,DV))
- GOTO DV
- SET I=$PIECE(DC(DV),U,1)
- SET D=DK
- SET DN=0
- SET Y="DO YOU WANT THIS SEARCH SPECIFICATION TO BE CONSIDERED TRUE FOR CONDITION -"_$CHAR(DV+64)_"-"
- G SET DN=DN+1
- SET P=$PIECE(I,C,1)
- SET I=$PIECE(I,C,2,99)
- IF P["W"
- GOTO W
- IF I=""
- GOTO DV
- IF P<0
- SET J=DY(-P)
- SET D=+J
- SET R=" '"_$PIECE(^DIC(D,0),U,1)_"' ENTRIES "
- IF '$PIECE(J,U,3)
- GOTO G
- +1 IF '$TEST
- SET D=+$PIECE(^DD(D,P,0),U,2)
- SET R=" '"_$ORDER(^DD(D,0,"NM",0))_"' MULTIPLES "
- HOW WRITE !!,Y,!?8,"1) WHEN AT LEAST ONE OF THE"_R_"SATISFIES IT"
- +1 WRITE !?8,"2) WHEN ALL OF THE"_R_"SATISFY IT"
- SET X=2
- +2 IF DV(DV)
- WRITE !?8,"3) WHEN ALL OF THE"_R_"SATISFY IT,",!?16,"OR WHEN THERE ARE NO"_R
- SET X=3
- +3 WRITE !?4,"CHOOSE 1-"_X_": "
- IF DV(DV)>1
- WRITE 3
- SET %1=3
- +4 IF '$TEST
- WRITE 1
- SET %1=1
- +5 READ "// ",%:DTIME,!
- IF '$TEST
- SET DTOUT=1
- IF %=""
- SET %=%1
- KILL %1
- IF %=U!'$TEST
- GOTO Q
- IF %>X!'%
- GOTO HOW
- IF %>1
- SET DE(DL,DV,DN)=%
- SET O=O+1
- SET ^UTILITY($JOB,O,0)=" for all"_R_$PIECE(", or when no"_R_"exist",U,%>2)
- +6 GOTO G
- +7 ;
- W IF DV(DV)-2
- SET DE(DL,DV,DN)=DV(DV)
- GOTO DV
- +1 WRITE !!,Y,!?7,"WHEN THERE IS NO '"_$PIECE(^DD(D,+P,0),U,1)_"' TEXT AT ALL"
- +2 SET %=1
- DO YN^DICN
- IF %<0
- GOTO Q
- IF '%
- GOTO W
- SET DE(DL,DV,DN)=4-%
- GOTO DV
- +3 ;
- 1 KILL O,DX,Y
- GOTO ^DIS1
